wingo pushed a commit to branch main in repository guile. commit 069ed42f502c327755c10b9bc3d5f6b3bdd79202 Author: Andy Wingo <wi...@pobox.com> AuthorDate: Thu Jun 22 11:25:16 2023 +0200
Tree-IL-to-CPS lowers to high-level object reprs: strings * module/language/tree-il/compile-cps.scm: Lower to string-length, string-ref, et al. --- module/language/tree-il/compile-cps.scm | 60 ++++----------------------------- 1 file changed, 6 insertions(+), 54 deletions(-) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 8cfa714b6..7bf88f6cd 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -944,19 +944,15 @@ (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) + (letv 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))))) + ($continue k src + ($primcall 'string-length #f (x))))) (letk kheap-object ($kargs () () ($branch knot-string ks src 'string? #f (x)))) @@ -990,7 +986,6 @@ (lambda (cps k src op param s idx) (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) @@ -1003,56 +998,13 @@ ($kargs ('uchar) (uchar) ($continue k src ($primcall 'tag-char #f (uchar))))) - (letk kassume - ($kargs ('u32) (u32) - ($continue kchar src - ($primcall 'assume-u64 '(0 . #xffffff) (u32))))) - (letk kwideref - ($kargs ('uwpos) (uwpos) - ($continue kassume src - ($primcall 'u32-ref 'stringbuf (buf ptr uwpos))))) - (letk kwide - ($kargs () () - ($continue kwideref src - ($primcall 'ulsh/immediate 2 (upos))))) - (letk knarrow + (letk kref ($kargs () () ($continue kchar src - ($primcall 'u8-ref 'stringbuf (buf ptr upos))))) - (letk kcmp - ($kargs ('bits) (bits) - ($branch kwide knarrow src 'u64-imm-= 0 (bits)))) - (letk kmask - ($kargs ('mask) (mask) - ($continue kcmp src - ($primcall 'ulogand #f (tag mask))))) - (letk ktag - ($kargs ('tag) (tag) - ($continue kmask src - ($primcall 'load-u64 stringbuf-f-wide ())))) - (letk kptr - ($kargs ('ptr) (ptr) - ($continue ktag src - ($primcall 'word-ref/immediate '(stringbuf . 0) (buf))))) - (letk kwidth - ($kargs ('buf) (buf) - ($continue kptr src - ($primcall 'tail-pointer-ref/immediate '(stringbuf . 2) (buf))))) - (letk kbuf - ($kargs ('upos) (upos) - ($continue kwidth src - ($primcall 'scm-ref/immediate '(string . 1) (s))))) - (letk kadd - ($kargs ('start) (start) - ($continue kbuf src - ($primcall 'uadd #f (start uidx))))) - (letk kstart - ($kargs () () - ($continue kadd src - ($primcall 'word-ref/immediate '(string . 2) (s))))) + ($primcall 'string-ref #f (s uidx))))) (letk krange ($kargs ('uidx) (uidx) - ($branch kout-of-range kstart src 'u64-< #f (uidx ulen)))) + ($branch kout-of-range kref src 'u64-< #f (uidx ulen)))) (build-term ($continue krange src ($primcall 'scm->u64 #f (idx)))))))))