[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 05/24: Add VM ops needed for string-ref
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 05/24: Add VM ops needed for string-ref |
|
Date: |
Tue, 10 Apr 2018 13:24:13 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 91d0db1bf7f721d026e13cfba6f9051bd2ca32d5
Author: Andy Wingo <address@hidden>
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
- [Guile-commits] 04/24: CPS conversion lowers string-length, (continued)
- [Guile-commits] 04/24: CPS conversion lowers string-length, Andy Wingo, 2018/04/10
- [Guile-commits] 10/24: Remove string-set! VM op, Andy Wingo, 2018/04/10
- [Guile-commits] 07/24: Remove now-unused string-length, string-ref, Andy Wingo, 2018/04/10
- [Guile-commits] 03/24: Remove specific instructions for add, etc from VM, Andy Wingo, 2018/04/10
- [Guile-commits] 06/24: Lower string-ref in CPS conversion, Andy Wingo, 2018/04/10
- [Guile-commits] 11/24: Instruction explosion for integer->char, Andy Wingo, 2018/04/10
- [Guile-commits] 16/24: Add load-label instruction, Andy Wingo, 2018/04/10
- [Guile-commits] 21/24: Add string->number etc as macro instructions to reify-primitives, Andy Wingo, 2018/04/10
- [Guile-commits] 12/24: Remove integer->char op, Andy Wingo, 2018/04/10
- [Guile-commits] 13/24: Instruction explosion for char->integer, Andy Wingo, 2018/04/10
- [Guile-commits] 05/24: Add VM ops needed for string-ref,
Andy Wingo <=
- [Guile-commits] 01/24: Add instrinsics to runtime, Andy Wingo, 2018/04/10
- [Guile-commits] 02/24: Compile some generic arithmetic to intrinsic calls, Andy Wingo, 2018/04/10
- [Guile-commits] 23/24: Remove class-of opcode, Andy Wingo, 2018/04/10
- [Guile-commits] 19/24: string->number, etc intrinsics, Andy Wingo, 2018/04/10
- [Guile-commits] 24/24: Remove load-typed-array, make-array opcodes, Andy Wingo, 2018/04/10
- [Guile-commits] 20/24: Remove string->number, etc opcodes, Andy Wingo, 2018/04/10
- [Guile-commits] 09/24: Explode "string-set!", Andy Wingo, 2018/04/10
- [Guile-commits] 14/24: Remove char->integer from VM, Andy Wingo, 2018/04/10
- [Guile-commits] 17/24: Add $code CPS expression type, Andy Wingo, 2018/04/10
- [Guile-commits] 15/24: Remove dead code in CPS converter, Andy Wingo, 2018/04/10