[Guile-commits] 09/24: Explode "string-set!"

[Andy Wingo]

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)