[Guile-commits] 07/08: Add integer->char and char->integer opcodes

[Andy Wingo]

wingo pushed a commit to branch wip-port-refactor
in repository guile.

commit f5b9a53bd07301bfd83e55d5c1d2dd13d4e4b250
Author: Andy Wingo <address@hidden>
Date:   Wed May 4 12:31:44 2016 +0200

    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.
---
 doc/ref/vm.texi                          |   10 +++++++
 libguile/vm-engine.c                     |   43 ++++++++++++++++++++++++++++--
 libguile/vm.c                            |    7 +++++
 module/language/cps/compile-bytecode.scm |    4 +++
 module/language/cps/slot-allocation.scm  |    1 +
 module/language/cps/types.scm            |    6 ++---
 module/language/tree-il/compile-cps.scm  |   11 ++++++--
 module/system/vm/assembler.scm           |    2 ++
 8 files changed, 77 insertions(+), 7 deletions(-)

diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi
index 528b66d..70aa364 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.
 
address@hidden 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}.
address@hidden deftypefn
+
address@hidden Instruction {} char->integer s12:@var{dst} s12:@var{src}
+Convert the Scheme character in @var{src} to an integer, and place it in
address@hidden as an unboxed @code{u64} value.
address@hidden deftypefn
+
 
 @node Inlined Mathematical Instructions
 @subsubsection Inlined Mathematical Instructions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 0bd3e78..018f32f 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 4899a80..07d6c13 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 1cb85ad..ea5b59f 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 6e9188a..654dbda 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 4cfc71f..f5a83a1 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 419cb33..0b9c834 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 94ebf03..117bc6c 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