wingo pushed a commit to branch master in repository guile. commit 91d0db1bf7f721d026e13cfba6f9051bd2ca32d5 Author: Andy Wingo <wi...@pobox.com> Date: Sun Apr 8 21:26:46 2018 +0200
Add VM ops needed for string-ref * libguile/vm-engine.c (tail-pointer-ref/immediate, tag-char) (untag-char): New instructions. * module/language/cps/compile-bytecode.scm (compile-function): Add support for new instructions. * module/language/cps/cse.scm (compute-equivalent-subexpressions): CSE cases for tag-char / untag-char. * module/language/cps/effects-analysis.scm: * module/language/cps/types.scm: Add cases for new primcalls. * module/language/cps/reify-primitives.scm (reify-primitives): Update comment. * module/language/cps/slot-allocation.scm (compute-var-representations): Add cases for untag-char, tail-pointer-ref/immediate. * module/language/cps/specialize-primcalls.scm (specialize-primcalls): Add untag-char case, and add FIXME comment for tag-char. * module/system/vm/assembler.scm: Export new assemblers. --- libguile/vm-engine.c | 31 +++++++++++++++++++++++----- module/language/cps/compile-bytecode.scm | 7 +++++++ module/language/cps/cse.scm | 5 ++++- module/language/cps/effects-analysis.scm | 5 ++++- module/language/cps/reify-primitives.scm | 2 +- module/language/cps/slot-allocation.scm | 6 ++++-- module/language/cps/specialize-primcalls.scm | 8 +++++-- module/language/cps/types.scm | 7 +++++++ module/system/vm/assembler.scm | 3 +++ 9 files changed, 62 insertions(+), 12 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index fd68148..b6b312c 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1431,10 +1431,15 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (47, unused_47, NULL, NOP) + VM_DEFINE_OP (47, tail_pointer_ref_immediate, "tail-pointer-ref/immediate", OP1 (X8_S8_S8_C8) | OP_DST) { - vm_error_bad_instruction (op); - abort (); + scm_t_uint8 dst, obj, idx; + + UNPACK_8_8_8 (op, dst, obj, idx); + + SP_SET_PTR (dst, ((scm_t_bits *) SCM2PTR (SP_REF (obj))) + idx); + + NEXT (1); } @@ -2206,8 +2211,24 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, - VM_DEFINE_OP (81, unused_81, NULL, NOP) - VM_DEFINE_OP (82, unused_82, NULL, NOP) + VM_DEFINE_OP (81, tag_char, "tag-char", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); + SP_SET (dst, + SCM_MAKE_ITAG8 ((scm_t_bits) (scm_t_wchar) SP_REF_U64 (src), + scm_tc8_char)); + NEXT (1); + } + + VM_DEFINE_OP (82, untag_char, "untag-char", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); + SP_SET_U64 (dst, SCM_CHAR (SP_REF (src))); + NEXT (1); + } + VM_DEFINE_OP (83, unused_83, NULL, NOP) VM_DEFINE_OP (84, unused_84, NULL, NOP) VM_DEFINE_OP (85, unused_85, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 8e6388a..a5488d4 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -172,6 +172,9 @@ (emit-word-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx)) (($ $primcall 'pointer-ref/immediate (annotation . idx) (obj)) (emit-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx)) + (($ $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 'integer->char #f (src)) @@ -269,6 +272,10 @@ (emit-untag-fixnum asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'tag-fixnum #f (src)) (emit-tag-fixnum asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'untag-char #f (src)) + (emit-untag-char asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'tag-char #f (src)) + (emit-tag-char asm (from-sp dst) (from-sp (slot src)))) (($ $primcall name #f args) ;; FIXME: Inline all the cases. (emit-text asm `((,name ,(from-sp dst) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index d4a294c..3956145 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -275,7 +275,10 @@ false. It could be that both true and false proofs are available." ((s <- tag-fixnum #f u) (u <- scm->s64 #f s) (u <- untag-fixnum #f s)) ((s <- u64->s64 #f u) (u <- s64->u64 #f s)) - ((u <- s64->u64 #f s) (s <- u64->s64 #f u))))) + ((u <- s64->u64 #f s) (s <- u64->s64 #f u)) + + ((u <- untag-char #f s) (s <- tag-char #f u)) + ((s <- tag-char #f u) (u <- untag-char #f s))))) (define (visit-label label equiv-labels var-substs) (define (term-defs term) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 5d25171..72589fe 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -395,7 +395,8 @@ the LABELS that are clobbered by the effects of LABEL." (match param ((ann . idx) (&write-field - (annotation->memory-kind ann) idx))))) + (annotation->memory-kind ann) idx)))) + ((tail-pointer-ref/immediate obj))) ;; Strings. (define-primitive-effects @@ -542,6 +543,8 @@ the LABELS that are clobbered by the effects of LABEL." ;; Characters. (define-primitive-effects + ((untag-char _)) + ((tag-char _)) ((integer->char _) &type-check) ((char->integer _) &type-check)) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 4e5bd5d..4e0e872 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -352,7 +352,7 @@ (setk label ($kargs names vars ($continue kop src ($primcall 'load-u64 n ()))))))))) - ;; Assume pointer-ref/immediate is within u8 range. + ;; Assume (tail-)pointer-ref/immediate is within u8 range. (((or 'word-ref/immediate 'scm-ref/immediate) obj) (match param ((ann . idx) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 4ba7d54..6f19f7d 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -758,7 +758,8 @@ are comparable with eqv?. A tmp slot may be used." 'uadd/immediate 'usub/immediate 'umul/immediate 'ursh/immediate 'ulsh/immediate 'u8-ref 'u16-ref 'u32-ref 'u64-ref - 'word-ref 'word-ref/immediate)) + 'word-ref 'word-ref/immediate + 'untag-char)) (intmap-add representations var 'u64)) (($ $primcall (or 'untag-fixnum 'assume-s64 @@ -766,7 +767,8 @@ are comparable with eqv?. A tmp slot may be used." 'srsh 'srsh/immediate 's8-ref 's16-ref 's32-ref 's64-ref)) (intmap-add representations var 's64)) - (($ $primcall (or 'pointer-ref/immediate)) + (($ $primcall (or 'pointer-ref/immediate + 'tail-pointer-ref/immediate)) (intmap-add representations var 'ptr)) (_ (intmap-add representations var 'scm)))) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index 96d7e11..51c10a2 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -124,7 +124,7 @@ (('allocate-words (? uint? n)) (allocate-words/immediate n ())) (('scm-ref o (? uint? i)) (scm-ref/immediate i (o))) (('scm-set! o (? uint? i) x) (scm-set!/immediate i (o x))) - ;; Assume pointer-ref/immediate can always be emitted directly. + ;; Assume (tail-)pointer-ref/immediate can always be emitted directly. (('word-ref o (? uint? i)) (word-ref/immediate i (o))) (('word-set! o (? uint? i) x) (word-set!/immediate i (o x))) (('add x (? num? y)) (add/immediate y (x))) @@ -139,7 +139,11 @@ (('scm->u64 (? u64? var)) (load-u64 var ())) (('scm->u64/truncate (? u64? var)) (load-u64 var ())) (('scm->s64 (? s64? var)) (load-s64 var ())) - (('untag-fixnum (? s64? var)) (load-s64 var ())))) + (('untag-fixnum (? s64? var)) (load-s64 var ())) + (('untag-char (? u64? var)) (load-u64 var ())) + ;; FIXME: add support for tagging immediate chars + ;; (('tag-char (? u64? var)) (load-const var ())) + )) (intmap-map (lambda (label cont) (match cont diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 6ce51de..72e5f94 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -787,6 +787,8 @@ minimum, and maximum." (define-type-inferrer/param (pointer-ref/immediate param obj result) (define! result &other-heap-object -inf.0 +inf.0)) +(define-type-inferrer/param (tail-pointer-ref/immediate param obj result) + (define! result &other-heap-object -inf.0 +inf.0)) (define-type-inferrer/param (assume-u64 param val result) (match param @@ -1616,6 +1618,11 @@ minimum, and maximum." ;;; Characters. ;;; +(define-type-inferrer (untag-char c result) + (define! result &s64 0 (min (&max c) *max-codepoint*))) +(define-type-inferrer (tag-char u64 result) + (define! result &char 0 (min (&max u64) *max-codepoint*))) + (define-simple-type-checker (integer->char (&u64 0 *max-codepoint*))) (define-type-inferrer (integer->char i result) (restrict! i &u64 0 *max-codepoint*) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 14a0a34..fba4e22 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -103,6 +103,8 @@ emit-untag-fixnum emit-tag-fixnum + emit-untag-char + emit-tag-char emit-throw (emit-throw/value* . emit-throw/value) @@ -157,6 +159,7 @@ emit-pointer-ref/immediate emit-pointer-set!/immediate + emit-tail-pointer-ref/immediate emit-u8-ref emit-s8-ref