[Guile-commits] 04/24: CPS conversion lowers string-length

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 39fb7e540b5aae269f71205ade03bc7f3e579e55
Author: Andy Wingo <address@hidden>
Date:   Sat Mar 31 03:14:47 2018 +0200

    CPS conversion lowers string-length
    
    * module/language/cps/types.scm (annotation->type):
    * module/language/cps/effects-analysis.scm (annotation->memory-kind):
      Add case for string memory kinds.  Remove special type and effect
      inferrers for string-length.
    * module/language/cps/slot-allocation.scm (compute-var-representations):
      Remove string-length.
    * module/language/tree-il/compile-cps.scm (ensure-string): New helper.
      (string-length): Add custom converter.
---
 module/language/cps/effects-analysis.scm |  4 ++--
 module/language/cps/slot-allocation.scm  |  1 -
 module/language/cps/types.scm            |  6 +-----
 module/language/tree-il/compile-cps.scm  | 33 +++++++++++++++++++++++++++++++-
 4 files changed, 35 insertions(+), 9 deletions(-)

diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 3c52225..5d25171 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -346,6 +346,7 @@ the LABELS that are clobbered by the effects of LABEL."
   (match annotation
     ('pair &pair)
     ('vector &vector)
+    ('string &string)
     ('bytevector &bytevector)
     ('bitmask &bitmask)
     ('box &box)
@@ -401,8 +402,7 @@ the LABELS that are clobbered by the effects of LABEL."
   ((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)
-  ((string-length s)                                           &type-check))
+  ((string->number _)              (&read-object &string)      &type-check))
 
 ;; Unboxed floats and integers.
 (define-primitive-effects
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index a378c5c..4ba7d54 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -752,7 +752,6 @@ are comparable with eqv?.  A tmp slot may be used."
               (intmap-add representations var 'f64))
              (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
                                'char->integer 's64->u64
-                               'string-length
                                'assume-u64
                                'uadd 'usub 'umul
                                'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 225b99c..6ce51de 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -727,6 +727,7 @@ minimum, and maximum."
   (match ann
     ('pair &pair)
     ('vector &vector)
+    ('string &string)
     ('bytevector &bytevector)
     ('box &box)
     ('closure &procedure)
@@ -848,11 +849,6 @@ minimum, and maximum."
   (restrict! idx &u64 0 (1- (&max/size s)))
   (restrict! val &char 0 *max-codepoint*))
 
-(define-simple-type-checker (string-length &string))
-(define-type-inferrer (string-length s result)
-  (restrict! s &string 0 (target-max-size-t))
-  (define! result &u64 (&min/0 s) (&max/size s)))
-
 (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 8047440..c3d9c07 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1156,11 +1156,42 @@
   (bv-f32-set! bytevector-ieee-single-native-set! f32-set! 4 float)
   (bv-f64-set! bytevector-ieee-double-native-set! f64-set! 8 float))
 
+(define (ensure-string cps src op x have-length)
+  (define msg "Wrong type argument in position 1 (expecting string): ~S")
+  (define not-string (vector 'wrong-type-arg (symbol->string op) msg))
+  (with-cps cps
+    (letv ulen rlen)
+    (letk knot-string
+          ($kargs () () ($throw src 'throw/value+data not-string (x))))
+    (let$ body (have-length rlen))
+    (letk k ($kargs ('rlen) (rlen) ,body))
+    (letk kassume
+          ($kargs ('ulen) (ulen)
+            ($continue k src
+              ($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (ulen)))))
+    (letk ks
+          ($kargs () ()
+            ($continue kassume src
+              ($primcall 'word-ref/immediate '(string . 3) (x)))))
+    (letk kheap-object
+          ($kargs () ()
+            ($branch knot-string ks src 'string? #f (x))))
+    (build-term
+      ($branch knot-string kheap-object src 'heap-object? #f (x)))))
+
+(define-primcall-converter string-length
+  (lambda (cps k src op param x)
+    (ensure-string
+     cps src op x
+     (lambda (cps ulen)
+       (with-cps cps
+         (build-term
+           ($continue k src ($primcall 'u64->scm #f (ulen)))))))))
+
 (define-primcall-converters
   (char->integer scm >u64)
   (integer->char u64 >scm)
 
-  (string-length scm >u64)
   (string-ref scm u64 >scm) (string-set! scm u64 scm)
 
   (rsh scm u64 >scm)