[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 09/24: Explode "string-set!"
From: |
Andy Wingo |
Subject: |
[Guile-commits] 09/24: Explode "string-set!" |
Date: |
Tue, 10 Apr 2018 13:24:14 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 2964abad053f3793dc84e00605b6c06c57975825
Author: Andy Wingo <address@hidden>
Date: Tue Apr 10 12:05:01 2018 +0200
Explode "string-set!"
* module/language/cps/effects-analysis.scm (string-ref): Remove effects
declaration, given that the primitive is exploded now.
* module/language/cps/reify-primitives.scm (compute-known-primitives):
Add string-set!.
* libguile/vm-engine.c (string-set!): Disable opcode.
* module/language/cps/types.scm (string-ref, string-set!): Remove type
checker and inferrers for string-ref and string-set!, as both are
exploded. In the case of string-set! there are still type-check
effects in the intrinsic call but they can't be elided by the checker,
as we don't track when strings are read-only.
* module/language/tree-il/compile-cps.scm (ensure-char): New helper.
(string-set!): New primcall exploded converter.
---
libguile/vm-engine.c | 2 +-
module/language/cps/effects-analysis.scm | 1 -
module/language/cps/reify-primitives.scm | 1 +
module/language/cps/types.scm | 19 ---------------
module/language/tree-il/compile-cps.scm | 42 ++++++++++++++++++++++++++++++--
module/system/vm/assembler.scm | 3 ++-
6 files changed, 44 insertions(+), 24 deletions(-)
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 188d529..215c334 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3083,7 +3083,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
*
* Store the character SRC into the string DST at index IDX.
*/
- VM_DEFINE_OP (192, string_set, "string-set!", OP1 (X8_S8_S8_S8))
+ VM_DEFINE_OP (192, unused_192, NULL, NOP)
{
scm_t_uint8 dst, idx, src;
SCM str, chr;
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 9133b95..98eee02 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -401,7 +401,6 @@ the LABELS that are clobbered by the effects of LABEL."
;; Strings.
(define-primitive-effects
- ((string-ref s n) (&read-object &string) &type-check)
((string-set! s n c) (&write-object &string) &type-check)
((number->string _) (&allocate &string) &type-check)
((string->number _) (&read-object &string) &type-check))
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 4e0e872..f08ade9 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -212,6 +212,7 @@
logand
logior
logxor
+ string-set!
u64->s64
s64->u64
cache-current-module!
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index e552a1a..f0313b9 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -833,25 +833,6 @@ minimum, and maximum."
;;; Strings.
;;;
-(define-type-checker (string-ref s idx)
- (and (check-type s &string 0 (target-max-size-t))
- (check-type idx &u64 0 (target-max-size-t))
- (< (&max idx) (&min s))))
-(define-type-inferrer (string-ref s idx result)
- (restrict! s &string (1+ (&min/0 idx)) (target-max-size-t))
- (restrict! idx &u64 0 (1- (&max/size s)))
- (define! result &char 0 *max-codepoint*))
-
-(define-type-checker (string-set! s idx val)
- (and (check-type s &string 0 (target-max-size-t))
- (check-type idx &u64 0 (target-max-size-t))
- (check-type val &char 0 *max-codepoint*)
- (< (&max idx) (&min s))))
-(define-type-inferrer (string-set! s idx val)
- (restrict! s &string (1+ (&min/0 idx)) (target-max-size-t))
- (restrict! idx &u64 0 (1- (&max/size s)))
- (restrict! val &char 0 *max-codepoint*))
-
(define-simple-type (number->string &number) (&string 0 (target-max-size-t)))
(define-simple-type (string->number (&string 0 (target-max-size-t)))
((logior &number &special-immediate) -inf.0 +inf.0))
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 39d6a53..ed27777 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1179,6 +1179,20 @@
(build-term
($branch knot-string kheap-object src 'heap-object? #f (x)))))
+(define (ensure-char cps src op x have-char)
+ (define msg "Wrong type argument (expecting char): ~S")
+ (define not-char (vector 'wrong-type-arg (symbol->string op) msg))
+ (with-cps cps
+ (letv uchar)
+ (letk knot-char
+ ($kargs () () ($throw src 'throw/value+data not-char (x))))
+ (let$ body (have-char uchar))
+ (letk k ($kargs ('uchar) (uchar) ,body))
+ (letk kchar
+ ($kargs () () ($continue k src ($primcall 'untag-char #f (x)))))
+ (build-term
+ ($branch knot-char kchar src 'char? #f (x)))))
+
(define-primcall-converter string-length
(lambda (cps k src op param x)
(ensure-string
@@ -1258,12 +1272,36 @@
(build-term
($continue krange src ($primcall 'scm->u64 #f (idx)))))))))
+(define-primcall-converter string-set!
+ (lambda (cps k src op param s idx ch)
+ (define out-of-range
+ #(out-of-range string-ref "Argument 2 out of range: ~S"))
+ (define stringbuf-f-wide #x400)
+ (ensure-string
+ cps src op s
+ (lambda (cps ulen)
+ (ensure-char
+ cps src op ch
+ (lambda (cps uchar)
+ (with-cps cps
+ (letv uidx)
+ (letk kout-of-range
+ ($kargs () ()
+ ($throw src 'throw/value+data out-of-range (idx))))
+ (letk kuidx
+ ($kargs () ()
+ ($continue k src
+ ($primcall 'string-set! #f (s uidx uchar)))))
+ (letk krange
+ ($kargs ('uidx) (uidx)
+ ($branch kout-of-range kuidx src 'u64-< #f (uidx ulen))))
+ (build-term
+ ($continue krange src ($primcall 'scm->u64 #f (idx)))))))))))
+
(define-primcall-converters
(char->integer scm >u64)
(integer->char u64 >scm)
- (string-set! scm u64 scm)
-
(rsh scm u64 >scm)
(lsh scm u64 >scm))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index bb1b5a3..ffc9138 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -195,6 +195,7 @@
emit-logand
emit-logior
emit-logxor
+ emit-string-set!
emit-call
emit-call-label
@@ -230,7 +231,6 @@
emit-current-thread
emit-fluid-ref
emit-fluid-set!
- emit-string-set!
emit-string->number
emit-string->symbol
emit-symbol->keyword
@@ -1297,6 +1297,7 @@ returned instead."
(define-scm<-scm-scm-intrinsic logand)
(define-scm<-scm-scm-intrinsic logior)
(define-scm<-scm-scm-intrinsic logxor)
+(define-scm-u64-u64-intrinsic string-set!)
(define-macro-assembler (begin-program asm label properties)
(emit-label asm label)
- [Guile-commits] 21/24: Add string->number etc as macro instructions to reify-primitives, (continued)
- [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, 2018/04/10
- [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 <=
- [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
- [Guile-commits] 22/24: Class-of is intrinsic, Andy Wingo, 2018/04/10
- [Guile-commits] 18/24: Remove unused make-closure opcode., Andy Wingo, 2018/04/10
- [Guile-commits] 08/24: Add string-set! intrinsic, Andy Wingo, 2018/04/10