mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Tree-IL-to-CPS lowers to high-level object reprs: bytevectors

Browse source 
* module/language/tree-il/compile-cps.scm: Lower to bv-length,
bv-contents.
This commit is contained in:
Andy Wingo 2023-06-22 11:24:26 +02:00
parent e6bd13ea1e
commit d0677a362d
1 changed files with 8 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

25
module/language/tree-il/compile-cps.scm
View file

@ -737,7 +737,7 @@
(define (prepare-bytevector-access cps src op pred bv idx width (define (prepare-bytevector-access cps src op pred bv idx width
have-ptr-and-uidx) have-ptr-and-uidx)
(with-cps cps (with-cps cps
(letv ulen rlen) (letv rlen)
(let$ access (let$ access
(untag-bytevector-index (untag-bytevector-index
src op idx rlen width src op idx rlen width
@ -748,17 +748,12 @@
(letk k ($kargs ('ptr) (ptr) ,body)) (letk k ($kargs ('ptr) (ptr) ,body))
(build-term (build-term
($continue k src ($continue k src
($primcall 'pointer-ref/immediate '(bytevector . 2) ($primcall 'bv-contents #f (bv))))))))
(bv))))))))
(letk k ($kargs ('rlen) (rlen) ,access)) (letk k ($kargs ('rlen) (rlen) ,access))
(letk kassume
($kargs ('ulen) (ulen)
($continue k src
($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (ulen)))))
(letk klen (letk klen
($kargs () () ($kargs () ()
($continue kassume src ($continue k src
($primcall 'word-ref/immediate '(bytevector . 1) (bv))))) ($primcall 'bv-length #f (bv)))))
($ (ensure-bytevector klen src op pred bv)))) ($ (ensure-bytevector klen src op pred bv))))
(define (bytevector-ref-converter scheme-name ptr-op width kind) (define (bytevector-ref-converter scheme-name ptr-op width kind)
@ -794,7 +789,7 @@
(lambda (cps ptr uidx) (lambda (cps ptr uidx)
(with-cps cps (with-cps cps
(letv val) (letv val)
(let$ body (tag k src val)) (let$ body (tag k src val))
(letk ktag ($kargs ('val) (val) ,body)) (letk ktag ($kargs ('val) (val) ,body))
(build-term (build-term
($continue ktag src ($continue ktag src
@ -912,17 +907,13 @@
(define-primcall-converter bv-length (define-primcall-converter bv-length
(lambda (cps k src op param bv) (lambda (cps k src op param bv)
(with-cps cps (with-cps cps
(letv ulen rlen) (letv rlen)
(letk ktag ($kargs ('rlen) (rlen) (letk ktag ($kargs ('rlen) (rlen)
($continue k src ($primcall 'u64->scm #f (rlen))))) ($continue k src ($primcall 'u64->scm #f (rlen)))))
(letk kassume
($kargs ('ulen) (ulen)
($continue ktag src
($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (ulen)))))
(letk klen (letk klen
($kargs () () ($kargs () ()
($continue kassume src ($continue ktag src
($primcall 'word-ref/immediate '(bytevector . 1) (bv))))) ($primcall 'bv-length #f (bv)))))
($ (ensure-bytevector klen src op 'bytevector? bv))))) ($ (ensure-bytevector klen src op 'bytevector? bv)))))
(define-bytevector-ref-converters (define-bytevector-ref-converters