resolve.scm 28 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673
  1. ;;; WebAssembly resolver
  2. ;;; Copyright (C) 2023 Igalia, S.L.
  3. ;;; Copyright (C) 2023 Robin Templeton <robin@spritely.institute>
  4. ;;; Copyright (C) 2023 David Thompson <dave@spritely.institute>
  5. ;;;
  6. ;;; Licensed under the Apache License, Version 2.0 (the "License");
  7. ;;; you may not use this file except in compliance with the License.
  8. ;;; You may obtain a copy of the License at
  9. ;;;
  10. ;;; http://www.apache.org/licenses/LICENSE-2.0
  11. ;;;
  12. ;;; Unless required by applicable law or agreed to in writing, software
  13. ;;; distributed under the License is distributed on an "AS IS" BASIS,
  14. ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  15. ;;; See the License for the specific language governing permissions and
  16. ;;; limitations under the License.
  17. ;;; Commentary:
  18. ;;;
  19. ;;; Lowers WASM with human readable identifiers to WASM with only
  20. ;;; index references.
  21. ;;;
  22. ;;; Code:
  23. (define-module (wasm resolve)
  24. #:use-module (ice-9 match)
  25. #:use-module ((srfi srfi-1) #:select (list-index))
  26. #:use-module (srfi srfi-11)
  27. #:use-module (wasm types)
  28. #:export (resolve-wasm))
  29. (define (fold1 f l s0)
  30. (let lp ((l l) (s0 s0))
  31. (match l
  32. (() s0)
  33. ((elt . l) (lp l (f elt s0))))))
  34. (define (alist-sort alist)
  35. (sort alist (lambda (a b) (< (car a) (car b)))))
  36. (define (make-name-store)
  37. (let ((count 0)
  38. (ids (make-hash-table)))
  39. (values (lambda (id)
  40. (let ((idx count))
  41. (set! count (1+ count))
  42. (when id (hashq-set! ids id idx))
  43. idx))
  44. (lambda (id)
  45. (cond
  46. ((exact-integer? id) id)
  47. ((hashq-ref ids id))
  48. (else (error "unbound identifier" id))))
  49. (lambda ()
  50. (alist-sort
  51. (hash-fold (lambda (name idx result)
  52. (cons (cons idx name) result))
  53. '() ids))))))
  54. (define (make-indirect-name-store)
  55. (let ((table (make-hash-table)))
  56. (values (lambda (parent-id parent-idx id)
  57. (match (hashq-ref table parent-idx)
  58. (#f
  59. (let-values (((add-id! resolve-id name-map) (make-name-store)))
  60. (let ((procs (list add-id! resolve-id name-map)))
  61. (hashq-set! table parent-idx procs)
  62. (when parent-id
  63. (hashq-set! table parent-id procs)))
  64. (add-id! id)))
  65. ((add-id! resolve-id name-map)
  66. (add-id! id))))
  67. (lambda (parent-id-or-idx id-or-idx)
  68. (if (exact-integer? id-or-idx)
  69. id-or-idx
  70. (match (hashq-ref table parent-id-or-idx)
  71. ((add-id! resolve-id name-map)
  72. (resolve-id id-or-idx)))))
  73. (lambda ()
  74. (alist-sort
  75. (hash-fold
  76. (lambda (id-or-idx procs result)
  77. (if (exact-integer? id-or-idx)
  78. (match procs
  79. ((_ _ name-map)
  80. (match (name-map)
  81. ((name-map ..1) (cons (cons id-or-idx name-map) result))
  82. (_ result))))
  83. result))
  84. '()
  85. table))))))
  86. (define* (resolve-wasm mod #:key emit-names?)
  87. (define-values (add-type-id! resolve-type type-name-map) (make-name-store))
  88. (define-values (add-func-id! resolve-func func-name-map) (make-name-store))
  89. (define-values (add-table-id! resolve-table table-name-map) (make-name-store))
  90. (define-values (add-memory-id! resolve-memory memory-name-map) (make-name-store))
  91. (define-values (add-global-id! resolve-global global-name-map) (make-name-store))
  92. (define-values (add-elem-id! resolve-elem elem-name-map) (make-name-store))
  93. (define-values (add-data-id! resolve-data data-name-map) (make-name-store))
  94. (define-values (add-tag-id! resolve-tag tag-name-map) (make-name-store))
  95. (define-values (add-struct-field! resolve-struct-field struct-field-name-map)
  96. (make-indirect-name-store))
  97. (define-values (add-func-local! resolve-func-local func-local-name-map)
  98. (make-indirect-name-store))
  99. (define-values (add-func-label! resolve-func-label func-label-name-map)
  100. (make-indirect-name-store))
  101. (define (add-func-locals! func)
  102. (match func
  103. (($ <func> id ($ <type-use> _ type) locals)
  104. (let ((idx (resolve-func id)))
  105. (for-each (lambda (local-id)
  106. (add-func-local! id idx local-id))
  107. (append (map param-id (func-sig-params type))
  108. (map local-id locals)))))))
  109. (define (add-func-labels! func)
  110. (match func
  111. (($ <func> id _ _ body)
  112. (let ((idx (resolve-func id)))
  113. (let loop ((insts body))
  114. (match insts
  115. (() #t)
  116. ((((or 'block 'loop) label _ body) . rest)
  117. (add-func-label! id idx label)
  118. (loop body)
  119. (loop rest))
  120. ((('if label _ consequent alternate) . rest)
  121. (add-func-label! id idx label)
  122. (loop consequent)
  123. (loop alternate)
  124. (loop rest))
  125. ((_ . rest)
  126. (loop rest))))))))
  127. (define (resolve-memarg memarg)
  128. (match memarg
  129. (($ <mem-arg> id offset align)
  130. (make-mem-arg (resolve-memory id) offset align))))
  131. (define interned-strings (make-hash-table))
  132. (define interned-string-count 0)
  133. (define (intern-string string)
  134. (or (hash-ref interned-strings string)
  135. (let ((idx interned-string-count))
  136. (hash-set! interned-strings string idx)
  137. (set! interned-string-count (1+ idx))
  138. idx)))
  139. (define functions-used-as-values (make-hash-table))
  140. (define (record-function-used-as-value idx)
  141. (unless (exact-integer? idx) (error "expected resolved idx"))
  142. (hashv-set! functions-used-as-values idx #t)
  143. idx)
  144. (define (type-use-matcher params results)
  145. (define param-type (match-lambda (($ <param> id type) type)))
  146. (lambda (rec type-id type-idx supers type)
  147. (and (null? supers)
  148. (match type
  149. (($ <func-sig> params' results')
  150. (and (equal? (map param-type params)
  151. (map param-type params'))
  152. (equal? results results')
  153. (make-type-use type-idx (make-func-sig params results))))
  154. (_ #f)))))
  155. (define (adjoin-types-from-type-uses types funcs imports tags)
  156. (define (adjoin-type-use type types)
  157. (match type
  158. (($ <type-use> #f ($ <func-sig> params results))
  159. (if (find-type (type-use-matcher params results) types)
  160. types
  161. (append types
  162. (list (make-type #f (make-func-sig params results))))))
  163. (($ <type-use>) types)))
  164. (define (adjoin-type-uses-from-tag-type type types)
  165. (match type
  166. (($ <tag-type> attribute type)
  167. (adjoin-type-use type types))))
  168. (define (adjoin-type-uses-from-import import types)
  169. (match import
  170. (($ <import> mod name 'func id type)
  171. (adjoin-type-use type types))
  172. (($ <import> mod name 'tag id type)
  173. (adjoin-type-uses-from-tag-type type types))
  174. (($ <import>) types)))
  175. (define (adjoin-type-uses-from-tag tag types)
  176. (match tag
  177. (($ <tag> id type)
  178. (adjoin-type-uses-from-tag-type type types))))
  179. (define (adjoin-type-uses-from-func func types)
  180. (define (adjoin-type-use-for-block-type x types)
  181. (match x
  182. (($ <type-use> #f ($ <func-sig> () (or () (_))))
  183. types)
  184. (_ (adjoin-type-use x types))))
  185. (define (adjoin-type-uses-for-inst inst types)
  186. (match inst
  187. (((or 'block 'loop) label type body)
  188. (fold1 adjoin-type-uses-for-inst body
  189. (adjoin-type-use-for-block-type type types)))
  190. (('if label type consequent alternate)
  191. (adjoin-type-uses-from-body
  192. consequent
  193. (adjoin-type-uses-from-body
  194. alternate
  195. (adjoin-type-use-for-block-type type types))))
  196. (('try label type body catches catch-all)
  197. (fold1 adjoin-type-uses-from-body (append body catches)
  198. (adjoin-type-use-for-block-type
  199. type
  200. (if catch-all
  201. (adjoin-type-uses-from-body catch-all types)
  202. types))))
  203. (('try_delegate label type body handler)
  204. (adjoin-type-uses-from-body
  205. body
  206. (adjoin-type-use-for-block-type type types)))
  207. (((or 'call_indirect 'return_call_indirect) table type)
  208. (adjoin-type-use type types))
  209. (_ types)))
  210. (define (adjoin-type-uses-from-body insts types)
  211. (fold1 adjoin-type-uses-for-inst insts types))
  212. (match func
  213. (($ <func> id type locals body)
  214. (adjoin-type-uses-from-body body (adjoin-type-use type types)))))
  215. (fold1 adjoin-type-uses-from-func funcs
  216. (fold1 adjoin-type-uses-from-tag tags
  217. (fold1 adjoin-type-uses-from-import imports types))))
  218. (match mod
  219. (($ <wasm> id %types imports funcs tables memories globals exports start
  220. elems datas tags strings custom)
  221. (define (generate-names)
  222. (make-names id
  223. (func-name-map)
  224. (func-local-name-map)
  225. (func-label-name-map)
  226. (type-name-map)
  227. (table-name-map)
  228. (memory-name-map)
  229. (global-name-map)
  230. (elem-name-map)
  231. (data-name-map)
  232. (struct-field-name-map)
  233. (tag-name-map)))
  234. (define types (adjoin-types-from-type-uses %types funcs imports tags))
  235. (for-each (match-lambda (($ <type> id type) (add-type-id! id))
  236. (($ <rec-group> (($ <type> id type) ...))
  237. (for-each add-type-id! id)))
  238. types)
  239. (for-each (match-lambda (($ <import> mod name kind id type)
  240. (match kind
  241. ('func (add-func-id! id))
  242. ('global (add-global-id! id))
  243. ('table (add-table-id! id))
  244. ('memory (add-memory-id! id))
  245. ('tag (add-tag-id! id)))))
  246. imports)
  247. (for-each (match-lambda (($ <func> id type locals body)
  248. (add-func-id! id)))
  249. funcs)
  250. (for-each (match-lambda (($ <table> id type init)
  251. (add-table-id! id)))
  252. tables)
  253. (for-each (match-lambda (($ <memory> id type)
  254. (add-memory-id! id)))
  255. memories)
  256. (for-each (match-lambda (($ <global> id type init)
  257. (add-global-id! id)))
  258. globals)
  259. (for-each (match-lambda (($ <elem> id mode table type offset init)
  260. (add-elem-id! id)))
  261. elems)
  262. (for-each (match-lambda (($ <data> id mode mem offset init)
  263. (add-data-id! id)))
  264. datas)
  265. (for-each (match-lambda (($ <tag> id type)
  266. (add-tag-id! id)))
  267. tags)
  268. (for-each intern-string strings)
  269. (find-type (lambda (rec type-id type-idx supers type)
  270. (match type
  271. (($ <struct-type>
  272. (($ <field> field-id mutable? type) ...))
  273. (for-each
  274. (lambda (field-id)
  275. (add-struct-field! type-id type-idx field-id))
  276. field-id))
  277. (_ (values)))
  278. #f)
  279. types)
  280. (when emit-names?
  281. (for-each add-func-locals! funcs)
  282. (for-each add-func-labels! funcs))
  283. (define (type-by-idx idx)
  284. (or (find-type (lambda (rec type-id type-idx supers type)
  285. (and (eqv? type-idx idx)
  286. type))
  287. types)
  288. (error "unknown type" idx)))
  289. (define (resolve-heap-type ht)
  290. (match ht
  291. ((or 'func 'extern
  292. 'any 'eq 'i31 'noextern 'nofunc 'struct 'array 'none
  293. 'string 'stringview_wtf8 'stringview_wtf16 'stringview_iter)
  294. ht)
  295. (_ (resolve-type ht))))
  296. (define (resolve-val-type vt)
  297. (match vt
  298. ((or 'i32 'i64 'f32 'f64 'v128
  299. 'funcref 'externref 'anyref 'eqref 'i31ref
  300. 'nullexternref 'nullfuncref
  301. 'structref 'arrayref 'nullref
  302. 'stringref
  303. 'stringview_wtf8ref 'stringview_wtf16ref 'stringview_iterref)
  304. vt)
  305. (($ <ref-type> nullable? ht)
  306. (make-ref-type nullable? (resolve-heap-type ht)))))
  307. (define (resolve-ref-type rt)
  308. (resolve-val-type rt))
  309. (define (resolve-storage-type type)
  310. (match type
  311. ((or 'i8 'i16) type)
  312. (_ (resolve-val-type type))))
  313. (define (resolve-param param)
  314. (match param
  315. (($ <param> id type)
  316. (make-param id (resolve-val-type type)))))
  317. (define (resolve-type-use x)
  318. ;; Transform symbolic or anonymous type uses to indexed type
  319. ;; uses.
  320. (define (lookup-type-use params results)
  321. (or (find-type (type-use-matcher params results) types)
  322. (error "unreachable")))
  323. (match x
  324. (($ <type-use> idx (and use-sig ($ <func-sig> params results)))
  325. (if idx
  326. (let ((idx (resolve-type idx)))
  327. (let ((def-sig (type-by-idx idx)))
  328. (make-type-use idx
  329. (if (and (null? params) (null? results))
  330. def-sig
  331. use-sig))))
  332. (match (lookup-type-use params results)
  333. (($ <type-use> idx ($ <func-sig> params results))
  334. (let ((params (map resolve-param params))
  335. (results (map resolve-val-type results)))
  336. (make-type-use idx (make-func-sig params results)))))))))
  337. (define (resolve-type-use-as-idx x)
  338. (match (resolve-type-use x)
  339. (($ <type-use> idx func-sig)
  340. idx)))
  341. (define (resolve-block-type x)
  342. (match x
  343. (($ <type-use> #f ($ <func-sig> () ()))
  344. x)
  345. (($ <type-use> #f ($ <func-sig> () (ret)))
  346. (let ((ret (resolve-val-type ret)))
  347. (make-type-use #f (make-func-sig '() (list ret)))))
  348. (_ (resolve-type-use-as-idx x))))
  349. (define (resolve-instructions insts locals labels)
  350. (define (resolve-i32 x)
  351. (if (< x (ash 1 31)) x (- x (ash 1 32))))
  352. (define (resolve-i64 x)
  353. (if (< x (ash 1 63)) x (- x (ash 1 64))))
  354. (define (resolve-label label)
  355. (match label
  356. ((? exact-integer?) label)
  357. (_
  358. (or (list-index (lambda (x) (eqv? x label)) labels)
  359. (error "unbound label" label labels)))))
  360. (define (resolve-local id)
  361. (match id
  362. ((? exact-integer?) id)
  363. (_
  364. (let ((local (list-index
  365. (lambda (local)
  366. (match local
  367. (($ <local> id* _) (eqv? id id*))
  368. (($ <param> id* _) (eqv? id id*))
  369. (_ #f)))
  370. locals)))
  371. (unless local
  372. (error "unbound local" id locals))
  373. local))))
  374. (map
  375. (match-lambda
  376. (((and inst (or 'block 'loop)) label type body)
  377. (let ((labels (cons label labels)))
  378. `(,inst ,label ,(resolve-block-type type)
  379. ,(resolve-instructions body locals labels))))
  380. (('if label type consequent alternate)
  381. (let ((labels (cons label labels)))
  382. `(if ,label ,(resolve-block-type type)
  383. ,(resolve-instructions consequent locals labels)
  384. ,(resolve-instructions alternate locals labels))))
  385. (('try label type body catches catch-all)
  386. (let ((labels (cons label labels)))
  387. `(try ,label ,(resolve-block-type type)
  388. ,(resolve-instructions body locals labels)
  389. ,(map (match-lambda
  390. ((tag . body)
  391. (cons (resolve-tag tag)
  392. (resolve-instructions body locals labels))))
  393. catches)
  394. ,(resolve-instructions catch-all locals labels))))
  395. (('try_delegate label type body handler)
  396. (let ((labels (cons label labels)))
  397. `(try_delegate ,label ,(resolve-block-type type)
  398. ,(resolve-instructions body locals labels)
  399. ,(resolve-label handler))))
  400. (((and inst 'throw) tag) `(,inst ,(resolve-tag tag)))
  401. (((and inst (or 'br 'br_if 'rethrow)) label)
  402. `(,inst ,(resolve-label label)))
  403. (('br_table targets default)
  404. `(br_table ,(map resolve-label targets) ,(resolve-label default)))
  405. (((and inst (or 'call 'return_call)) label)
  406. `(,inst ,(resolve-func label)))
  407. (('call_indirect table type)
  408. `(call_indirect ,(resolve-table table) ,(resolve-type-use-as-idx type)))
  409. (((and inst (or 'call_ref 'return_call_ref)) type)
  410. `(,inst ,(resolve-type type)))
  411. (('select types) `(select ,(map resolve-val-type types)))
  412. (((and inst (or 'local.get 'local.set 'local.tee)) local)
  413. `(,inst ,(resolve-local local)))
  414. (((and inst (or 'global.get 'global.set)) global)
  415. `(,inst ,(resolve-global global)))
  416. (((and inst (or 'table.get 'table.set)) table)
  417. `(,inst ,(resolve-table table)))
  418. (((and inst (or 'memory.size 'memory.grow)) mem)
  419. `(,inst ,(resolve-memory mem)))
  420. (((and inst (or 'i32.load 'i64.load 'f32.load 'f64.load
  421. 'i32.load8_s 'i32.load8_u 'i32.load16_s 'i32.load16_u
  422. 'i64.load8_s 'i64.load8_u 'i64.load16_s 'i64.load16_u
  423. 'i64.load32_s 'i64.load32_u
  424. 'i32.store 'i64.store 'f32.store 'f64.store
  425. 'i32.store8 'i32.store16
  426. 'i64.store8 'i64.store16 'i64.store32))
  427. mem)
  428. `(,inst ,(resolve-memarg mem)))
  429. (('i32.const x) `(i32.const ,(resolve-i32 x)))
  430. (('i64.const x) `(i64.const ,(resolve-i64 x)))
  431. (('ref.null ht) `(ref.null ,(resolve-heap-type ht)))
  432. (('ref.func f) `(ref.func ,(record-function-used-as-value
  433. (resolve-func f))))
  434. ;; GC instructions.
  435. (((and inst (or 'ref.test 'ref.cast)) rt)
  436. `(,inst ,(resolve-ref-type rt)))
  437. (((and inst (or 'br_on_cast 'br_on_cast_fail)) label rt1 rt2)
  438. `(,inst ,(resolve-label label)
  439. ,(resolve-ref-type rt1) ,(resolve-ref-type rt2)))
  440. (((and inst (or 'struct.get 'struct.get_s 'struct.get_u 'struct.set))
  441. type field)
  442. `(,inst ,(resolve-type type) ,(resolve-struct-field type field)))
  443. (((and inst (or 'struct.new 'struct.new_default)) type)
  444. `(,inst ,(resolve-type type)))
  445. (((and inst (or 'array.get 'array.get_s 'array.get_u 'array.set)) type)
  446. `(,inst ,(resolve-type type)))
  447. (('array.new_fixed type len)
  448. `(array.new_fixed ,(resolve-type type) ,len))
  449. (((and inst (or 'array.new 'array.new_default)) type)
  450. `(,inst ,(resolve-type type)))
  451. (((and inst (or 'array.new_data 'array.init_data)) type data)
  452. `(,inst ,(resolve-type type) ,(resolve-data data)))
  453. (((and inst (or 'array.new_elem 'array.init_elem)) type elem)
  454. `(,inst ,(resolve-type type) ,(resolve-elem elem)))
  455. (('array.fill type)
  456. `(array.fill ,(resolve-type type)))
  457. (('array.copy dst src)
  458. `(array.copy ,(resolve-type dst) ,(resolve-type src)))
  459. ;; Stringref instructions.
  460. (('string.const (? string? str))
  461. `(string.const ,(intern-string str)))
  462. (((and inst (or 'string.new_utf8 'string.new_lossy_utf8 'string.new_wtf8
  463. 'string.new_wtf16
  464. 'string.encode_utf8 'string.encode_lossy_utf8
  465. 'string.encode_wtf8 'string.encode_wtf16
  466. 'stringview_wtf8.encode_utf8
  467. 'stringview_wtf8.encode_lossy_utf8
  468. 'stringview_wtf8.encode_wtf8
  469. 'stringview_wtf16.encode))
  470. mem)
  471. `(,inst ,(resolve-memarg mem)))
  472. ;; Misc instructions.
  473. (('memory.init data mem)
  474. `(memory.init ,(resolve-data data) ,(resolve-memory mem)))
  475. (('data.drop data)
  476. `(data.drop ,(resolve-data data)))
  477. (('memory.copy dst src)
  478. `(memory.copy ,(resolve-memory dst) ,(resolve-memory src)))
  479. (('memory.fill mem)
  480. `(memory.fill ,(resolve-memory mem)))
  481. (('table.init table elem)
  482. `(table.init ,(resolve-table table) ,(resolve-elem elem)))
  483. (('elem.drop elem)
  484. `(elem.drop ,(resolve-elem elem)))
  485. (('table.copy dst src)
  486. `(table.copy ,(resolve-table dst) ,(resolve-table src)))
  487. (((and inst (or 'table.grow 'table.size 'table.fill)) table)
  488. `(,inst ,(resolve-table table)))
  489. ;; Not yet implemented: simd mem ops, atomic mem ops.
  490. ((? symbol? op) `(,op))
  491. (inst inst))
  492. insts))
  493. (define (visit-type type)
  494. (define (resolve-field field)
  495. (match field
  496. (($ <field> id mutable? type)
  497. (make-field id mutable? (resolve-storage-type type)))))
  498. (define (resolve-base type)
  499. (match type
  500. (($ <func-sig> params results)
  501. (make-func-sig (map resolve-param params)
  502. (map resolve-val-type results)))
  503. (($ <array-type> mutable? type)
  504. (make-array-type mutable? (resolve-storage-type type)))
  505. (($ <struct-type> fields)
  506. (make-struct-type (map resolve-field fields)))))
  507. (define (resolve-sub type)
  508. (match type
  509. (($ <type> id type)
  510. (make-type id
  511. (match type
  512. (($ <sub-type> final? supers type)
  513. (make-sub-type final?
  514. (map resolve-heap-type supers)
  515. (resolve-base type)))
  516. (_ (resolve-base type)))))))
  517. (match type
  518. (($ <rec-group> sub-types)
  519. (make-rec-group (map resolve-sub sub-types)))
  520. (_ (resolve-sub type))))
  521. (define (visit-import import)
  522. (match import
  523. (($ <import> mod name 'func id type)
  524. (make-import mod name 'func id (resolve-type-use type)))
  525. (($ <import> mod name 'global id ($ <global-type> mutable? type))
  526. (make-import mod name 'global id
  527. (make-global-type mutable? (resolve-val-type type))))
  528. ((and import ($ <import> mod name 'memory))
  529. import)
  530. (($ <import> mod name 'table id ($ <table-type> limits type))
  531. (make-import mod name 'table id
  532. (make-table-type limits (resolve-val-type type))))
  533. (($ <import> mod name 'tag id ($ <tag-type> attribute type))
  534. (make-import mod name 'tag id
  535. (make-tag-type attribute (resolve-type-use type))))))
  536. (define (visit-export export)
  537. (match export
  538. (($ <export> name 'func id)
  539. (make-export name 'func (resolve-func id)))
  540. (($ <export> name 'table id)
  541. (make-export name 'table (resolve-table id)))
  542. (($ <export> name 'memory id)
  543. (make-export name 'memory (resolve-memory id)))
  544. (($ <export> name 'global id)
  545. (make-export name 'global (resolve-global id)))
  546. (($ <export> name 'tag id)
  547. (make-export name 'tag (resolve-tag id)))))
  548. (define (strip-declarative-segments elems)
  549. (filter (match-lambda
  550. (($ <elem> id mode) (not (eq? mode 'declarative))))
  551. elems))
  552. (define (add-declarative-segment elems)
  553. (match (sort (hash-map->list (lambda (k v) k) functions-used-as-values)
  554. <)
  555. (() elems)
  556. (funcs
  557. (let ((declarative (make-elem #f 'declarative #f 'funcref #f
  558. (map (lambda (func-idx)
  559. `((ref.func ,func-idx)))
  560. funcs))))
  561. (append elems (list declarative))))))
  562. (define (visit-elem elem)
  563. (match elem
  564. (($ <elem> id mode table type offset init)
  565. (make-elem id mode (and table (resolve-table table))
  566. (resolve-val-type type)
  567. (and offset (resolve-instructions offset '() '()))
  568. (map (lambda (init)
  569. (resolve-instructions init '() '()))
  570. init)))))
  571. (define (visit-data data)
  572. (match data
  573. (($ <data> id mode mem offset init)
  574. (make-data id mode (and mem (resolve-memory mem))
  575. (and offset (resolve-instructions offset '() '()))
  576. init))))
  577. (define (visit-start start)
  578. (and start (resolve-func start)))
  579. (define (visit-func func)
  580. (define (visit-local local)
  581. (match local
  582. (($ <local> id type)
  583. (make-local id (resolve-val-type type)))))
  584. (match func
  585. (($ <func> id type locals body)
  586. (match (resolve-type-use type)
  587. ((and type ($ <type-use> idx ($ <func-sig> params _)))
  588. (make-func id type (map visit-local locals)
  589. (resolve-instructions body
  590. (append params locals)
  591. '())))))))
  592. (define (visit-table table)
  593. (match table
  594. (($ <table> id ($ <table-type> limits type) init)
  595. (make-table id
  596. (make-table-type limits (resolve-val-type type))
  597. (and init (resolve-instructions init '() '()))))))
  598. (define (visit-memory mem) mem)
  599. (define (visit-global global)
  600. (match global
  601. (($ <global> id ($ <global-type> mutable? type) init)
  602. (make-global id
  603. (make-global-type mutable? (resolve-val-type type))
  604. (resolve-instructions init '() '())))))
  605. (define (visit-tag tag)
  606. (match tag
  607. (($ <tag> id ($ <tag-type> attribute type))
  608. (make-tag id (make-tag-type attribute (resolve-type-use type))))))
  609. (let ((types (map visit-type types))
  610. (imports (map visit-import imports))
  611. (exports (map visit-export exports))
  612. (%elems (map visit-elem (strip-declarative-segments elems)))
  613. (datas (map visit-data datas))
  614. (start (visit-start start))
  615. (funcs (map visit-func funcs))
  616. (tables (map visit-table tables))
  617. (memories (map visit-memory memories))
  618. (globals (map visit-global globals))
  619. (tags (map visit-tag tags))
  620. (custom (if emit-names?
  621. (cons (generate-names) custom)
  622. custom)))
  623. (define strings
  624. (map car
  625. (sort (hash-map->list cons interned-strings)
  626. (match-lambda*
  627. (((s1 . idx1) (s2 . idx2)) (< idx1 idx2))))))
  628. (define elems (add-declarative-segment %elems))
  629. (make-wasm #f types imports funcs tables memories globals exports start
  630. elems datas tags strings custom)))))