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