wingo pushed a commit to branch master in repository guile. commit 39fb7e540b5aae269f71205ade03bc7f3e579e55 Author: Andy Wingo <wi...@pobox.com> 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)