[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/24: CPS conversion lowers string-length
From: |
Andy Wingo |
Subject: |
[Guile-commits] 04/24: CPS conversion lowers string-length |
Date: |
Tue, 10 Apr 2018 13:24:13 -0400 (EDT) |
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)
- [Guile-commits] branch master updated (98fc9c0 -> 59f1f5a), Andy Wingo, 2018/04/10
- [Guile-commits] 04/24: CPS conversion lowers string-length,
Andy Wingo <=
- [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, 2018/04/10