wingo pushed a commit to branch main in repository guile. commit e6bd13ea1ef63fee64880ddc2215a25ce5435d0f Author: Andy Wingo <wi...@pobox.com> AuthorDate: Thu Jun 22 11:24:07 2023 +0200
Tree-IL-to-CPS lowers to high-level object reprs: structs * module/language/tree-il/compile-cps.scm: Lower to allocate-struct, struct-ref, and so on. --- module/language/tree-il/compile-cps.scm | 157 +++++++------------------------- 1 file changed, 33 insertions(+), 124 deletions(-) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 7979f4ff1..4ff63500f 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -523,7 +523,7 @@ (let$ body (have-vtable vtable)) (letk k ($kargs ('vtable) (vtable) ,body)) (letk kvtable ($kargs () () - ($continue k src ($primcall 'scm-ref/tag 'struct (x))))) + ($continue k src ($primcall 'struct-vtable #f (x))))) (letk kheap-object ($kargs () () ($branch knot-struct kvtable src 'struct? #f (x)))) (build-term ($branch knot-struct kheap-object src 'heap-object? #f (x))))) @@ -545,42 +545,19 @@ (vector 'wrong-type-arg (symbol->string op) "Wrong type argument in position 1 (expecting vtable): ~S")) - (define vtable-index-flags 1) ; FIXME: pull from struct.h - (define vtable-offset-flags (1+ vtable-index-flags)) - (define vtable-validated-mask #b11) - (define vtable-validated-value #b11) (with-cps cps - (letv flags mask res) - (letk knot-vtable + (letk kf ($kargs () () ($throw src 'throw/value+data not-vtable (vtable)))) (let$ body (is-vtable)) (letk k ($kargs () () ,body)) - (letk ktest - ($kargs ('res) (res) - ($branch knot-vtable k src - 'u64-imm-= vtable-validated-value (res)))) - (letk kand - ($kargs ('mask) (mask) - ($continue ktest src - ($primcall 'ulogand #f (flags mask))))) - (letk kflags - ($kargs ('flags) (flags) - ($continue kand src - ($primcall 'load-u64 vtable-validated-mask ())))) (build-term - ($continue kflags src - ($primcall 'word-ref/immediate - `(struct . ,vtable-offset-flags) (vtable-vtable)))))))) + ($branch kf k src 'vtable-vtable? #f (vtable-vtable))))))) (define-primcall-converter allocate-struct - (lambda (cps k src op nwords vtable) + (lambda (cps k src op nfields vtable) (ensure-vtable cps src 'allocate-struct vtable (lambda (cps) - (define vtable-index-size 5) ; FIXME: pull from struct.h - (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h - (define vtable-offset-size (1+ vtable-index-size)) - (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields)) (define wrong-number (vector 'wrong-number-of-args (symbol->string op) @@ -589,80 +566,40 @@ (vector 'wrong-type-arg (symbol->string op) "Expected vtable with no unboxed fields: ~A")) - (define (check-all-boxed cps kf kt vtable ptr word) - (if (< (* word 32) nwords) - (with-cps cps - (letv idx bits) - (let$ checkboxed (check-all-boxed kf kt vtable ptr (1+ word))) - (letk kcheckboxed ($kargs () () ,checkboxed)) - (letk kcheck - ($kargs ('bits) (bits) - ($branch kf kcheckboxed src 'u64-imm-= 0 (bits)))) - (letk kword - ($kargs ('idx) (idx) - ($continue kcheck src - ($primcall 'u32-ref 'bitmask (vtable ptr idx))))) - (build-term - ($continue kword src - ($primcall 'load-u64 word ())))) - (with-cps cps - (build-term ($continue kt src ($values ())))))) (with-cps cps - (letv rfields nfields ptr s) + (letv actual-nfields) (letk kwna ($kargs () () ($throw src 'throw/value wrong-number (vtable)))) (letk kunboxed ($kargs () () ($throw src 'throw/value+data has-unboxed (vtable)))) - (letk kdone - ($kargs () () ($continue k src ($values (s))))) - (letk ktag - ($kargs ('s) (s) - ($continue kdone src - ($primcall 'scm-set!/tag 'struct (s vtable))))) (letk kalloc ($kargs () () - ($continue ktag src - ($primcall 'allocate-words/immediate - `(struct . ,(1+ nwords)) ())))) - (let$ checkboxed (check-all-boxed kunboxed kalloc vtable ptr 0)) - (letk kcheckboxed ($kargs ('ptr) (ptr) ,checkboxed)) + ($continue k src + ($primcall 'allocate-struct nfields (vtable))))) (letk kaccess ($kargs () () - ($continue kcheckboxed src - ($primcall 'pointer-ref/immediate - `(struct . ,vtable-offset-unboxed-fields) - (vtable))))) + ($branch kalloc kunboxed src + 'vtable-has-unboxed-fields? nfields (vtable)))) (letk knfields - ($kargs ('nfields) (nfields) - ($branch kwna kaccess src 'u64-imm-= nwords (nfields)))) - (letk kassume - ($kargs ('rfields) (rfields) - ($continue knfields src - ($primcall 'assume-u64 `(0 . ,(target-max-size-t/scm)) - (rfields))))) + ($kargs ('nfields) (actual-nfields) + ($branch kwna kaccess src + 'u64-imm-= nfields (actual-nfields)))) (build-term - ($continue kassume src - ($primcall 'word-ref/immediate - `(struct . ,vtable-offset-size) (vtable))))))))) - -(define (ensure-struct-index-in-range cps src op vtable idx boxed? in-range) - (define vtable-index-size 5) ; FIXME: pull from struct.h - (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h - (define vtable-offset-size (1+ vtable-index-size)) - (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields)) + ($continue knfields src + ($primcall 'vtable-size #f (vtable))))))))) + +(define (ensure-struct-index-in-range cps src op vtable idx in-range) (define bad-type (vector 'wrong-type-arg (symbol->string op) - (if boxed? - "Wrong type argument in position 2 (expecting boxed field): ~S" - "Wrong type argument in position 2 (expecting unboxed field): ~S"))) + "Wrong type argument in position 2 (expecting boxed field): ~S")) (define out-of-range (vector 'out-of-range (symbol->string op) "Argument 2 out of range: ~S")) (with-cps cps - (letv rfields nfields ptr word bits mask res throwval1 throwval2) + (letv nfields throwval1 throwval2) (letk kthrow1 ($kargs (#f) (throwval1) ($throw src 'throw/value+data out-of-range (throwval1)))) @@ -674,45 +611,17 @@ (let$ body (in-range)) (letk k ($kargs () () ,body)) - (letk ktest - ($kargs ('res) (res) - ($branch (if boxed? kbadtype k) (if boxed? k kbadtype) src - 'u64-imm-= 0 (res)))) - (letk kand - ($kargs ('mask) (mask) - ($continue ktest src - ($primcall 'ulogand #f (mask bits))))) - (letk kbits - ($kargs ('bits) (bits) - ($continue kand src - ($primcall 'load-u64 (ash 1 (logand idx 31)) ())))) - (letk kword - ($kargs ('word) (word) - ($continue kbits src - ($primcall 'u32-ref 'bitmask (vtable ptr word))))) - (letk kptr - ($kargs ('ptr) (ptr) - ($continue kword src - ($primcall 'load-u64 (ash idx -5) ())))) (letk kaccess ($kargs () () - ($continue kptr src - ($primcall 'pointer-ref/immediate - `(struct . ,vtable-offset-unboxed-fields) - (vtable))))) + ($branch kbadtype k src 'vtable-field-boxed? idx (vtable)))) (letk knfields ($kargs ('nfields) (nfields) ($branch kbadidx kaccess src 'imm-u64-< idx (nfields)))) - (letk kassume - ($kargs ('rfields) (rfields) - ($continue knfields src - ($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (rfields))))) (build-term - ($continue kassume src - ($primcall 'word-ref/immediate - `(struct . ,vtable-offset-size) (vtable)))))) + ($continue knfields src + ($primcall 'vtable-size #f (vtable)))))) -(define (prepare-struct-scm-access cps src op struct idx boxed? have-pos) +(define (prepare-struct-scm-access cps src op struct idx in-range) (define not-struct (vector 'wrong-type-arg (symbol->string op) @@ -720,38 +629,38 @@ (ensure-struct cps src op struct (lambda (cps vtable) - (ensure-struct-index-in-range - cps src op vtable idx boxed? - (lambda (cps) (have-pos cps (1+ idx))))))) + (ensure-struct-index-in-range cps src op vtable idx in-range)))) (define-primcall-converter struct-ref/immediate (lambda (cps k src op param struct) + (define idx param) (prepare-struct-scm-access - cps src op struct param #t - (lambda (cps pos) + cps src op struct idx + (lambda (cps) (with-cps cps (build-term ($continue k src - ($primcall 'scm-ref/immediate `(struct . ,pos) (struct))))))))) + ($primcall 'struct-ref idx (struct))))))))) (define-primcall-converter struct-set!/immediate (lambda (cps k src op param struct val) + (define idx param) (prepare-struct-scm-access - cps src op struct param #t - (lambda (cps pos) + cps src op struct idx + (lambda (cps) (with-cps cps (letk k* ($kargs () () ($continue k src ($values (val))))) (build-term ($continue k* src - ($primcall 'scm-set!/immediate `(struct . ,pos) (struct val))))))))) + ($primcall 'struct-set! idx (struct val))))))))) (define-primcall-converter struct-init! (lambda (cps k src op param s val) - (define pos (1+ param)) + (define idx param) (with-cps cps (build-term ($continue k src - ($primcall 'scm-set!/immediate `(struct . ,pos) (s val))))))) + ($primcall 'struct-set! idx (s val))))))) (define-primcall-converter struct-ref (lambda (cps k src op param struct idx)