Add integer->char and char->integer opcodes

* libguile/vm-engine.c (integer_to_char, char_to_integer): New opcodes.
* libguile/vm.c (vm_error_not_a_char): New error case.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/slot-allocation.scm (compute-var-representations):
* module/language/cps/types.scm:
* module/language/tree-il/compile-cps.scm (convert):
* doc/ref/vm.texi (Inlined Scheme Instructions):
* module/system/vm/assembler.scm: Add support for new opcodes.

8 files changed, 77 insertions, 7 deletions

diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 528b66d92..70aa364d9 100644
--- a/doc/ref/vm.texi
+++ b/doc/ref/vm.texi
@@ -1352,6 +1352,16 @@ Set the cdr of @var{dst} to @var{src}.
 Note that @code{caddr} and friends compile to a series of @code{car}
 and @code{cdr} instructions.
 
+@deftypefn Instruction {} integer->char s12:@var{dst} s12:@var{src}
+Convert the @code{u64} value in @var{src} to a Scheme character, and
+place it in @var{dst}.
+@end deftypefn
+
+@deftypefn Instruction {} char->integer s12:@var{dst} s12:@var{src}
+Convert the Scheme character in @var{src} to an integer, and place it in
+@var{dst} as an unboxed @code{u64} value.
+@end deftypefn
+
 
 @node Inlined Mathematical Instructions
 @subsubsection Inlined Mathematical Instructions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 0bd3e78e9..018f32f04 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3733,8 +3733,47 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       BR_U64_SCM_COMPARISON(x, y, y <= 0 || (scm_t_uint64) y <= x, scm_geq_p);
     }
 
-  VM_DEFINE_OP (175, unused_175, NULL, NOP)
-  VM_DEFINE_OP (176, unused_176, NULL, NOP)
+  /* integer->char a:12 b:12
+   *
+   * Convert the U64 value in B to a Scheme character, and return it in
+   * A.
+   */
+  VM_DEFINE_OP (175, integer_to_char, "integer->char", OP1 (X8_S12_S12) | OP_DST)
+    {
+      scm_t_uint16 dst, src;
+      scm_t_uint64 x;
+
+      UNPACK_12_12 (op, dst, src);
+      x = SP_REF_U64 (src);
+
+      if (SCM_UNLIKELY (x > (scm_t_uint64) SCM_CODEPOINT_MAX))
+        vm_error_out_of_range_uint64 ("integer->char", x);
+
+      SP_SET (dst, SCM_MAKE_ITAG8 ((scm_t_bits) (scm_t_wchar) x, scm_tc8_char));
+
+      NEXT (1);
+    }
+
+  /* char->integer a:12 b:12
+   *
+   * Untag the character in B to U64, and return it in A.
+   */
+  VM_DEFINE_OP (176, char_to_integer, "char->integer", OP1 (X8_S12_S12) | OP_DST)
+    {
+      scm_t_uint16 dst, src;
+      SCM x;
+
+      UNPACK_12_12 (op, dst, src);
+      x = SP_REF (src);
+
+      if (SCM_UNLIKELY (!SCM_CHARP (x)))
+        vm_error_not_a_char ("char->integer", x);
+
+      SP_SET_U64 (dst, SCM_CHAR (x));
+
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (177, unused_177, NULL, NOP)
   VM_DEFINE_OP (178, unused_178, NULL, NOP)
   VM_DEFINE_OP (179, unused_179, NULL, NOP)
diff --git a/libguile/vm.c b/libguile/vm.c
index 4899a8038..07d6c13ee 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -442,6 +442,7 @@ static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_not_a_char (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE;
@@ -557,6 +558,12 @@ vm_error_improper_list (SCM x)
 }
 
 static void
+vm_error_not_a_char (const char *subr, SCM x)
+{
+  scm_wrong_type_arg_msg (subr, 1, x, "char");
+}
+
+static void
 vm_error_not_a_pair (const char *subr, SCM x)
 {
   scm_wrong_type_arg_msg (subr, 1, x, "pair");
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 1cb85ad7b..ea5b59f38 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -181,6 +181,10 @@
         (($ $primcall 'struct-ref/immediate (struct n))
          (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
                                     (constant n)))
+        (($ $primcall 'char->integer (src))
+         (emit-char->integer asm (from-sp dst) (from-sp (slot src))))
+        (($ $primcall 'integer->char (src))
+         (emit-integer->char asm (from-sp dst) (from-sp (slot src))))
         (($ $primcall 'add/immediate (x y))
          (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) (constant y)))
         (($ $primcall 'sub/immediate (x y))
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 6e9188aa0..654dbda39 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -802,6 +802,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
                                'bv-length 'vector-length 'string-length
                                'uadd 'usub 'umul
                                'ulogand 'ulogior 'ulogsub 'ursh 'ulsh
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 4cfc71fd6..f5a83a143 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1422,15 +1422,15 @@ minimum, and maximum."
   ((logior &true &false) 0 0))
 (define-type-aliases char<? char<=? char>=? char>?)
 
-(define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff)))
+(define-simple-type-checker (integer->char (&u64 0 #x10ffff)))
 (define-type-inferrer (integer->char i result)
-  (restrict! i &exact-integer 0 #x10ffff)
+  (restrict! i &u64 0 #x10ffff)
   (define! result &char (&min/0 i) (min (&max i) #x10ffff)))
 
 (define-simple-type-checker (char->integer &char))
 (define-type-inferrer (char->integer c result)
   (restrict! c &char 0 #x10ffff)
-  (define! result &exact-integer (&min/0 c) (min (&max c) #x10ffff)))
+  (define! result &u64 (&min/0 c) (min (&max c) #x10ffff)))
 
 
 
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index 419cb336b..0b9c834c4 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -576,8 +576,8 @@
                    (letk kbox ($kargs ('f64) (f64)
                                 ($continue k src ($primcall 'f64->scm (f64)))))
                    kbox))
-                ((string-length
-                  vector-length
+                ((char->integer
+                  string-length vector-length
                   bv-length bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref)
                  (with-cps cps
                    (letv u64)
@@ -670,6 +670,13 @@
                      cps nfields 'scm->u64
                      (lambda (cps nfields)
                        (have-args cps (list vtable nfields)))))))
+                ((integer->char)
+                 (match args
+                   ((integer)
+                    (unbox-arg
+                     cps integer 'scm->u64
+                     (lambda (cps integer)
+                       (have-args cps (list integer)))))))
                 (else (have-args cps args))))
             (convert-args cps args
               (lambda (cps args)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 94ebf0368..117bc6cf3 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -166,6 +166,8 @@
             emit-ulsh
             emit-ursh/immediate
             emit-ulsh/immediate
+            emit-char->integer
+            emit-integer->char
             emit-make-vector
             emit-make-vector/immediate
             emit-vector-length