mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-14 23:50:19 +02:00
Code Activity

Add integer->char and char->integer opcodes

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2016-05-04 12:31:44 +02:00
parent 2ba638092f
commit f5b9a53bd0
8 changed files with 77 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

10
doc/ref/vm.texi
View file

@ -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

43
libguile/vm-engine.c
View file

@ -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)

7
libguile/vm.c
View file

@ -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;
@ -556,6 +557,12 @@ vm_error_improper_list (SCM x)
vm_error ("Expected a proper list, but got object with tail ~s", 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)
{

4
module/language/cps/compile-bytecode.scm
View file

@ -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))

1
module/language/cps/slot-allocation.scm
View file

@ -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

6
module/language/cps/types.scm
View file

@ -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)))

11
module/language/tree-il/compile-cps.scm
View file

@ -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)

2
module/system/vm/assembler.scm
View file

@ -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