wingo pushed a commit to branch main
in repository guile.
commit 069ed42f502c327755c10b9bc3d5f6b3bdd79202
Author: Andy Wingo <[email protected]>
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)))))))))
