123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846 |
- (define-module (wasm lower-stringrefs)
- #:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (append-map filter-map))
- #:use-module (rnrs bytevectors)
- #:use-module (wasm link)
- #:use-module (wasm types)
- #:use-module (wasm wat)
- #:export (lower-stringrefs))
- (define (wtf8-stdlib)
-
-
-
- (define %wtf8-reject 0)
- (define %wtf8-accept 11)
- (define %wtf8-two-byte 22)
- (define %wtf8-three-byte 33)
- (define %wtf8-four-byte 44)
- (define %wtf8-four-byte-low 55)
- (define %wtf8-three-byte-high 66)
- (define %wtf8-four-byte-mid-high 77)
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- (define %wtf8-transitions
- #vu8(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
- 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
- 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
- 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2
- 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3
- 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3
- 8 8 4 4 4 4 4 4 4 4 4 4 4 4 4 4
- 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4
- 9 5 5 5 5 5 5 5 5 5 5 5 5 5 5 5
- 10 6 6 6 7 8 8 8 8 8 8 8 8 8 8 8))
-
-
-
-
-
-
-
-
-
-
-
-
- (define %wtf8-states
- #vu8(0 0 0 0 0 0 0 0 0 0 0
- 11 0 0 0 22 33 44 55 0 66 77
- 0 11 11 11 0 0 0 0 0 0 0
- 0 22 22 22 0 0 0 0 0 0 0
- 0 33 33 33 0 0 0 0 0 0 0
- 0 33 0 0 0 0 0 0 0 0 0
- 0 0 0 22 0 0 0 0 0 0 0
- 0 0 33 33 0 0 0 0 0 0 0))
- (wat->wasm
- `((type $wtf8 (array (mut i8)))
- (type $stringview-iter
- (struct (field $wtf8 (ref $wtf8))
- (field $pos (mut i32))))
- (func $wtf8->extern-string (import "rt" "wtf8_to_string")
- (param $wtf8 (ref null $wtf8))
- (result (ref extern)))
- (func $extern-string->wtf8 (import "rt" "string_to_wtf8")
- (param $str (ref null extern))
- (result (ref $wtf8)))
- (type $immutable-bytes (array i8))
- (data $wtf8-transitions ,%wtf8-transitions)
- (data $wtf8-states ,%wtf8-states)
- (global $wtf8-transitions (ref $immutable-bytes)
- (array.new_data $immutable-bytes $wtf8-transitions
- (i32.const 0)
- (i32.const
- ,(bytevector-length %wtf8-transitions))))
- (global $wtf8-states (ref $immutable-bytes)
- (array.new_data $immutable-bytes $wtf8-states
- (i32.const 0)
- (i32.const
- ,(bytevector-length %wtf8-states))))
- (func $decode-wtf8 (param $byte i32) (param $buf i32) (param $state i32)
- (result i32 i32)
- (local $type i32)
- (local.set $type
- (array.get_u $immutable-bytes
- (global.get $wtf8-transitions)
- (local.get $byte)))
-
- (i32.or (i32.shl (local.get $buf) (i32.const 6))
- (i32.and (local.get $byte)
- (i32.shr_u (i32.const #x7f)
- (i32.shr_u (local.get $type)
- (i32.const 1)))))
-
- (array.get_u $immutable-bytes
- (global.get $wtf8-states)
- (i32.add (local.get $state) (local.get $type))))
-
- (func $string.compare
- (param $a (ref $wtf8))
- (param $b (ref $wtf8))
- (result i32)
- (local $i i32)
- (local $d i32)
- (if (ref.eq (local.get $a) (local.get $b))
- (then (return (i32.const 0))))
- (loop $lp
- i32
- (if (i32.eq (array.len (local.get $a)) (local.get $i))
- (then
- (if (i32.eq (array.len (local.get $b)) (local.get $i))
- (then (return (i32.const 0)))
- (else (return (i32.const -1))))))
- (if (i32.eq (array.len (local.get $b)) (local.get $i))
- (then (return (i32.const 1))))
- (local.tee
- $d
- (i32.sub
- (array.get_u $wtf8 (local.get $a) (local.get $i))
- (array.get_u $wtf8 (local.get $b) (local.get $i))))
- (if (i32.eqz)
- (then
- (local.set $i
- (i32.add (local.get $i) (i32.const 1)))
- (br $lp)))
- (if i32
- (i32.lt_s (local.get $d) (i32.const 0))
- (then (i32.const -1))
- (else (i32.const 1)))))
- (func $string.eq (param $a (ref $wtf8)) (param $b (ref $wtf8))
- (result i32)
- (i32.eqz (call $string.compare (local.get $a) (local.get $b))))
- (func $string.as_iter (param $wtf8 (ref $wtf8))
- (result (ref $stringview-iter))
- (struct.new $stringview-iter (local.get $wtf8) (i32.const 0)))
- (func $stringview_iter.next
- (param $iter (ref $stringview-iter))
- (result i32)
- (local $wtf8 (ref $wtf8))
- (local $cp i32)
- (local $state i32)
- (local $i i32)
- (local.set $wtf8 (struct.get $stringview-iter $wtf8
- (local.get $iter)))
- (local.set $i (struct.get $stringview-iter $pos
- (local.get $iter)))
- (local.set $state (i32.const ,%wtf8-accept))
- (if (i32.ge_u (local.get $i) (array.len (local.get $wtf8)))
- (then (return (i32.const -1))))
- (loop $lp
- (call $decode-wtf8
- (array.get_u $wtf8 (local.get $wtf8) (local.get $i))
- (local.get $cp)
- (local.get $state))
- (local.set $state)
- (local.set $cp)
-
- (if (i32.eq (local.get $state) (i32.const ,%wtf8-reject))
- (then (unreachable)))
- (local.set $i (i32.add (local.get $i) (i32.const 1)))
- (if (i32.ne (local.get $state) (i32.const ,%wtf8-accept))
- (then
- (if (i32.ge_u (local.get $i) (array.len (local.get $wtf8)))
-
- (then (unreachable)))
- (br $lp))))
- (struct.set $stringview-iter $pos
- (local.get $iter) (local.get $i))
- (local.get $cp))
- (func $stringview_iter.advance
- (param $iter (ref $stringview-iter)) (param $count i32)
- (result i32)
- (local $wtf8 (ref $wtf8))
- (local $state i32)
- (local $i i32)
- (local $advanced i32)
- (local.set $wtf8 (struct.get $stringview-iter $wtf8
- (local.get $iter)))
- (local.set $i (struct.get $stringview-iter $pos (local.get $iter)))
- (local.set $state (i32.const ,%wtf8-accept))
- (if (i32.eqz (local.get $count))
- (then (return (i32.const 0))))
- (loop $lp
- (if (i32.lt_u (local.get $i) (array.len (local.get $wtf8)))
- (then
- (call $decode-wtf8
- (array.get_u $wtf8 (local.get $wtf8) (local.get $i))
- (i32.const 0)
- (local.get $state))
- (local.set $state)
- (drop)
-
- (if (i32.eq (local.get $state) (i32.const ,%wtf8-reject))
- (then (unreachable)))
- (local.set $i (i32.add (local.get $i) (i32.const 1)))
- (if (i32.eq (local.get $state (i32.const ,%wtf8-accept)))
- (then
- (local.set $advanced
- (i32.add (local.get $advanced)
- (i32.const 1)))
- (if (i32.lt_u (local.get $advanced)
- (local.get $count))
- (then (br $lp))))
- (else
- (br $lp))))
- (else
-
- (if (i32.ne (local.get $state) (i32.const ,%wtf8-accept))
- (then (unreachable))))))
- (struct.set $stringview-iter $pos (local.get $iter) (local.get $i))
- (local.get $advanced))
- (func $stringview_iter.slice
- (param $iter (ref $stringview-iter)) (param $count i32)
- (result (ref $wtf8))
- (local $wtf8 (ref $wtf8))
- (local $start i32)
- (local $len i32)
- (local $temp (ref $stringview-iter))
- (local $out (ref $wtf8))
- (local.set $wtf8 (struct.get $stringview-iter $wtf8
- (local.get $iter)))
- (local.set $start (struct.get $stringview-iter $pos
- (local.get $iter)))
- (local.set $temp (struct.new $stringview-iter (local.get $wtf8)
- (local.get $start)))
- (call $stringview_iter.advance (local.get $temp)
- (local.get $count))
- (drop)
- (local.set $len
- (i32.sub (struct.get $stringview-iter $pos
- (local.get $temp))
- (local.get $start)))
- (local.set $out (array.new_default $wtf8 (local.get $len)))
- (array.copy $wtf8 $wtf8
- (local.get $out) (i32.const 0)
- (local.get $wtf8) (local.get $start) (local.get $len))
- (local.get $out))
- (func $string.encode_wtf8_array
- (param $wtf8 (ref $wtf8)) (param $out (ref $wtf8)) (param $pos i32)
- (array.copy $wtf8 $wtf8
- (local.get $out)
- (local.get $pos)
- (local.get $wtf8)
- (i32.const 0)
- (array.len (local.get $wtf8))))
- (func $string.new_lossy_utf8_array
- (param $buf (ref $wtf8)) (param $start i32) (param $len i32)
- (result (ref $wtf8))
- (local $out (ref $wtf8))
-
- (local.set $out (array.new_default $wtf8 (local.get $len)))
- (array.copy $wtf8 $wtf8
- (local.get $out) (i32.const 0)
- (local.get $buf) (local.get $start) (local.get $len))
- (local.get $out))
- (func $string.measure_wtf16 (param $wtf8 (ref $wtf8)) (result i32)
- (local $iter (ref $stringview-iter))
- (local $cp i32)
- (local $count i32)
- (local.set $iter (call $string.as_iter (local.get $wtf8)))
- (loop $lp
- (local.set $cp (call $stringview_iter.next (local.get $iter)))
- (if (i32.le_s (i32.const 0) (local.get $cp))
- (then
- (local.set $count
- (i32.add (i32.add (local.get $count)
- (i32.const 1))
- (i32.gt_u (local.get $cp)
- (i32.const #xffff))))
- (br $lp))))
- (local.get $count)))))
- (define (import-is-external? mod name)
- (not (string-prefix? "$" name)))
- (define (export-is-external? name)
- (not (string-prefix? "$" name)))
- (define* (lower-stringrefs/wtf8 wasm #:key
- (import-is-external? import-is-external?)
- (export-is-external? export-is-external?))
- (define make-id
- (let ((counter 0))
- (lambda (stem)
- (let ((sym (string->symbol (format #f "~a-~a" stem counter))))
- (set! counter (1+ counter))
- sym))))
- (define %strings (make-hash-table))
- (define (intern-string! str)
- (or (hash-ref %strings str)
- (let ((id (make-id '$stringref)))
- (hash-set! %strings str id)
- id)))
- (match wasm
- (($ <wasm> id types imports funcs tables memories globals exports start
- elems datas tags () custom)
-
- (define (visit-heap-type type)
- (match type
- ('string '$wtf8)
- ('stringview_wtf8 (error "lowering wtf8 views unsupported"))
- ('stringview_wtf16 (error "lowering wtf16 views unsupported"))
- ('stringview_iter '$stringview-iter)
- (_ type)))
- (define (visit-val-type type)
- (match type
- (($ <ref-type> nullable? ht)
- (make-ref-type nullable? (visit-heap-type ht)))
- (_ type)))
- (define (visit-ref-type type)
- (visit-val-type type))
- (define (visit-param param)
- (match param
- (($ <param> id type)
- (make-param id (visit-val-type type)))))
- (define (visit-field field)
- (match field
- (($ <field> id mutable? type)
- (make-field id mutable? (visit-val-type type)))))
- (define (visit-func-sig type)
- (match type
- (($ <func-sig> params results)
- (make-func-sig (map visit-param params)
- (map visit-val-type results)))))
- (define (visit-base-type type)
- (match type
- (($ <struct-type> fields)
- (make-struct-type (map visit-field fields)))
- (($ <array-type> mutable? type)
- (make-array-type mutable? (visit-val-type type)))
- (_
- (visit-func-sig type))))
- (define (visit-sub-type type)
- (match type
- (($ <sub-type> final? supers type)
- (make-sub-type final? supers (visit-base-type type)))
- (_ (visit-base-type type))))
- (define (visit-type-use type)
- (match type
- (($ <type-use> id sig)
- (make-type-use id (visit-func-sig sig)))))
- (define (visit-table-type type)
- (match type
- (($ <table-type> limits elem-type)
- (make-table-type limits (visit-val-type elem-type)))))
- (define (visit-global-type type)
- (match type
- (($ <global-type> mutable? type)
- (make-global-type mutable? (visit-val-type type)))))
- (define (visit-tag-type type)
- (match type
- (($ <tag-type> attribute type)
- (make-tag-type attribute (visit-type-use type)))))
- (define (visit-block-type type)
- (match type
- (#f #f)
- (($ <type-use>) (visit-type-use type))
- ((or ($ <ref-type>) (? symbol?)) (visit-val-type type))))
- (define visit-inst
- (match-lambda
- (((and inst (or 'block 'loop)) label type body)
- `(,inst ,label ,(visit-block-type type)
- ,(visit-expr body)))
- (('if label type consequent alternate)
- `(if ,label ,(visit-block-type type)
- ,(visit-expr consequent)
- ,(visit-expr alternate)))
- (('try label type body catches catch-all)
- `(try ,label ,(visit-block-type type)
- ,(visit-expr body)
- ,(map visit-expr catches)
- ,(and=> catch-all visit-expr)))
- (('try_delegate label type body handler)
- `(try_delegate ,label ,(visit-block-type type)
- ,(visit-expr body)
- ,handler))
- (('call_indirect table type)
- `(call_indirect ,table ,(visit-type-use type)))
- (('select types) `(select ,(map visit-val-type types)))
-
- (('ref.null ht) `(ref.null ,(visit-heap-type ht)))
- (((and inst (or 'ref.test 'ref.cast)) rt)
- `(,inst ,(visit-ref-type rt)))
- (((and inst (or 'br_on_cast 'br_on_cast_fail)) label rt1 rt2)
- `(,inst ,label ,(visit-ref-type rt1) ,(visit-ref-type rt2)))
-
- (('string.const str) `(global.get ,(intern-string! str)))
- (('string.new_utf8 mem) `(call ,(symbol-append
- '$string.new_utf8_ mem)))
- (('string.new_lossy_utf8 mem) `(call ,(symbol-append
- '$string.new_lossy_utf8_ mem)))
- (('string.new_wtf8 mem) `(call ,(symbol-append
- '$string.new_wtf8_ mem)))
- (('string.new_wtf16 mem) `(call ,(symbol-append
- '$string.new_wtf16_ mem)))
- (('string.measure_wtf8) '(array.len))
- (('string.measure_utf8) '(call $string.measure_utf8))
- (('string.measure_wtf16) '(call $string.measure_wtf16))
- (('string.encode_utf8 mem) `(call ,(symbol-append
- '$string.encode_utf8_ mem)))
- (('string.encode_lossy_utf8 mem) `(call ,(symbol-append
- '$string.encode_lossy_utf8_ mem)))
- (('string.encode_wtf8 mem) `(call ,(symbol-append '$string.encode_wtf8_ mem)))
- (('string.encode_wtf16 mem) `(call ,(symbol-append
- '$string.encode_wtf16_ mem)))
- (('string.concat) '(call $string.concat))
- (('string.eq) '(call $string.eq))
- (('string.is_usv_sequence) '(call $string.is_usv_sequence))
- (('string.compare) '(call $string.compare))
- (('string.from_code_point) '(call $string.from_code_point))
- (('string.as_wtf8) '(call $string.as_wtf8))
- (('stringview_wtf8.advance) '(call $stringview_wtf8.advance))
- (('stringview_wtf8.encode_utf8 mem)
- `(call ,(symbol-append
- '$stringview_wtf8.encode_utf8_ mem)))
- (('stringview_wtf8.encode_lossy_utf8 mem)
- `(call ,(symbol-append
- '$stringview_wtf8.encode_lossy_utf8_ mem)))
- (('stringview_wtf8.encode_wtf8 mem)
- `(call ,(symbol-append
- '$stringview_wtf8.encode_wtf8_ mem)))
- (('stringview_wtf8.slice) '(call $stringview_wtf8.slice))
- (('string.as_wtf16) '(call $string.as_wtf16))
- (('stringview_wtf16.length) '(call $stringview_wtf16.length))
- (('stringview_wtf16.get_codeunit) `(call $stringview_wtf16.get_codeunit))
- (('stringview_wtf16.encode mem) `(call ,(symbol-append
- '$stringview_wtf16.encode_ mem)))
- (('stringview_wtf16.slice) '(call $stringview_wtf16.slice))
- (('string.as_iter) '(call $string.as_iter))
- (('stringview_iter.next) '(call $stringview_iter.next))
- (('stringview_iter.advance) '(call $stringview_iter.advance))
- (('stringview_iter.rewind) '(call $stringview_iter.rewind))
- (('stringview_iter.slice) '(call $stringview_iter.slice))
- (('string.new_utf8_array) '(call $string.new_utf8_array))
- (('string.new_lossy_utf8_array) '(call $string.new_lossy_utf8_array))
- (('string.new_wtf8_array) '(call $string.new_wtf8_array))
- (('string.new_wtf16_array) '(call $string.new_wtf16_array))
- (('string.encode_utf8_array) '(call $string.encode_utf8_array))
- (('string.encode_lossy_utf8_array) '(call $string.encode_lossy_utf8_array))
- (('string.encode_wtf8_array) '(call $string.encode_wtf8_array))
- (('string.encode_wtf16_array) '(call $string.encode_wtf16_array))
- (inst inst)))
- (define (visit-expr expr)
- (map visit-inst expr))
- (define (visit-init expr)
- (visit-expr expr))
- (define (visit-func func)
- (define visit-local
- (match-lambda
- (($ <local> id type)
- (make-local id (visit-val-type type)))))
- (match func
- (($ <func> id type locals body)
- (let ((type (visit-type-use type))
- (locals (map visit-local locals))
- (body (visit-expr body)))
- (make-func id type locals body)))))
- (define (lower-extern-val-type type)
- (match type
- (($ <ref-type> nullable? 'string)
- (make-ref-type nullable? 'extern))
- (($ <ref-type> nullable? (or 'stringview_wtf8
- 'stringview_wtf16
- 'stringview_iter))
- (error "extern param/result with stringview type unimplemented" type))
- (_ (visit-val-type type))))
- (define (lower-extern-val type)
- (match type
- (($ <ref-type> nullable? 'string)
- '((call $wtf8->extern-string)))
- (($ <ref-type> nullable? (or 'stringview_wtf8
- 'stringview_wtf16
- 'stringview_iter))
- (error "extern value with stringview type unimplemented" type))
- (_ '())))
- (define (lift-extern-val type)
- (match type
- (($ <ref-type> nullable? 'string)
- '((call $extern-string->wtf8)))
- (($ <ref-type> nullable? (or 'stringview_wtf8
- 'stringview_wtf16
- 'stringview_iter))
- (error "extern value with stringview type unimplemented" type))
- (_ '())))
- (define (lower-extern-func-type type)
- (match type
- (($ <type-use> tid
- ($ <func-sig> (($ <param> pid ptype) ...) (rtype ...)))
- (make-type-use tid
- (make-func-sig
- (map make-param pid
- (map lower-extern-val-type ptype))
- (map lower-extern-val-type rtype))))))
- (define (lower-extern-tag-type type)
- (match type
- (($ <tag-type> attribute type)
- (make-tag-type attribute (lower-extern-func-type type)))))
- (define (lower-extern-func-import id wrapped-id type)
- (match type
- (($ <type-use> _ ($ <func-sig> (($ <param> _ params) ...) results))
- (let ((param-count (length params)))
- (make-func
- id
- (visit-type-use type)
- (map (lambda (type) (make-local #f (lower-extern-val-type type)))
- results)
- (let lp ((params params) (i 0))
- (match params
- ((param . params)
- `((local.get ,i)
- ,@(lower-extern-val param)
- . ,(lp params (1+ i))))
- (()
- `((call ,wrapped-id)
- ,@(reverse (map (lambda (i) `(local.set ,i))
- (iota (length results) param-count)))
- . ,(let lp ((results results) (i param-count))
- (match results
- (() '())
- ((result . results)
- `((local.get ,i)
- ,@(lift-extern-val result)
- . ,(lp results (1+ i)))))))))))))))
- (define (lower-extern-func-export id wrapped-id type)
- (match type
- (($ <type-use> _ ($ <func-sig> (($ <param> _ params) ...) results))
- (let ((param-count (length params)))
- (make-func
- id
- (lower-extern-func-type type)
- (map (lambda (type) (make-local #f (visit-val-type type)))
- results)
- (let lp ((params params) (i 0))
- (match params
- ((param . params)
- `((local.get ,i)
- ,@(lift-extern-val param)
- . ,(lp params (1+ i))))
- (()
- `((call ,wrapped-id)
- ,@(reverse (map (lambda (i) `(local.set ,i))
- (iota (length results) param-count)))
- . ,(let lp ((results results) (i param-count))
- (match results
- (() '())
- ((result . results)
- `((local.get ,i)
- ,@(lower-extern-val result)
- . ,(lp results (1+ i)))))))))))))))
- (define (lookup-func-type id)
- (or (or-map (match-lambda
- (($ <import> mod name kind id' type)
- (and (eq? id id') type)))
- imports)
- (or-map (match-lambda
- (($ <func> id' type locals body)
- (and (eq? id id') type)))
- funcs)))
- (let ((types (map (match-lambda
- (($ <rec-group> (($ <type> id type) ...))
- (make-rec-group
- (map make-type id (map visit-sub-type type))))
- (($ <type> id type)
- (make-type id (visit-sub-type type))))
- types))
- (imports (map
- (match-lambda
- (($ <import> mod name kind id type)
- (let* ((type* (match kind
- ('func (if (import-is-external? mod name)
- (lower-extern-func-type type)
- (visit-type-use type)))
- ('table (visit-table-type type))
- ('memory type)
- ('global (visit-global-type type))
- ('tag (if (import-is-external? mod name)
- (lower-extern-tag-type type)
- (visit-tag-type type)))))
- (id* (and (eq? kind 'func)
- (import-is-external? mod name)
- (not (equal? type type*))
- (make-id (symbol-append id '-stringref)))))
- (cons (and id* (lower-extern-func-import id id* type))
- (make-import mod name kind (or id* id) type*)))))
- imports))
- (exports (map
- (match-lambda
- ((and export ($ <export> name kind id))
- (cond
- ((and (eq? kind 'func)
- (export-is-external? name)
- (and=>
- (lookup-func-type id)
- (lambda (type)
- (if (equal? type
- (lower-extern-func-type type))
- #f
- type))))
- => (lambda (type)
- (let ((id* (make-id
- (symbol-append id '-stringref))))
- (cons (lower-extern-func-export id* id type)
- (make-export name kind id*)))))
- (else
- (cons #f export)))))
- exports))
- (funcs (map visit-func funcs))
- (tables (map (match-lambda
- (($ <table> id type init)
- (make-table id (visit-table-type type)
- (and init (visit-init init)))))
- tables))
- (globals (map (match-lambda
- (($ <global> id ($ <global-type> mutable? vt) init)
- (let* ((vt (visit-val-type vt))
- (type (make-global-type mutable? vt)))
- (make-global id type (visit-init init)))))
- globals))
- (elems (map (match-lambda
- (($ <elem> id mode table type offset inits)
- (make-elem id mode table
- (visit-val-type type)
- (and=> offset visit-init)
- (map visit-init inits))))
- elems))
- (datas (map (match-lambda
- (($ <data> id mode mem offset init)
- (make-data id mode mem
- (and=> offset visit-init)
- init)))
- datas))
- (tags (map (match-lambda
- (($ <tag> id type)
- (make-tag id (visit-tag-type type))))
- tags)))
- (let* ((t (make-global-type #f (make-ref-type #f '$wtf8)))
- (strings (hash-map->list
- (lambda (str id)
- (make-global id t
- `((i32.const 0)
- (i32.const ,(bytevector-length
- (string->utf8 str)))
- (array.new_data $wtf8 ,id))))
- %strings))
- (wtf8 (hash-map->list
- (lambda (str id)
- (make-data id 'passive #f #f (string->utf8 str)))
- %strings)))
- (add-stdlib
- (make-wasm id
- types
- (map cdr imports)
- (append funcs
- (filter-map car imports)
- (filter-map car exports))
- tables
- memories
- (append strings globals)
- (map cdr exports)
- start
- elems
- (append wtf8 datas)
- tags
- '()
- custom)
- (wtf8-stdlib)))))))
- (define* (lower-stringrefs wasm #:key (strategy 'wtf8))
- (match strategy
- ('stringref wasm)
- ('wtf8 (lower-stringrefs/wtf8 wasm))
- (_ (error "unknown stringref lowering strategy" strategy))))
|