lower-primcalls.scm 25 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735
  1. ;;; Continuation-passing style (CPS) intermediate language (IL)
  2. ;; Copyright (C) 2023 Free Software Foundation, Inc.
  3. ;;; This library is free software; you can redistribute it and/or modify it
  4. ;;; under the terms of the GNU Lesser General Public License as published by
  5. ;;; the Free Software Foundation; either version 3 of the License, or (at
  6. ;;; your option) any later version.
  7. ;;;
  8. ;;; This library is distributed in the hope that it will be useful, but
  9. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
  11. ;;; General Public License for more details.
  12. ;;;
  13. ;;; You should have received a copy of the GNU Lesser General Public License
  14. ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  15. ;;; Commentary:
  16. ;;;
  17. ;;; When targetting Guile's virtual machine, we can get maximum
  18. ;;; performance by expanding out some compound primcalls, both so that
  19. ;;; they are available to common subexpression elimination and so that
  20. ;;; their lowered forms can be implemented using Guile's low-level VM
  21. ;;; capabilities instead of by call-outs to library routines.
  22. ;;;
  23. ;;; Code:
  24. (define-module (language cps guile-vm lower-primcalls)
  25. #:use-module (ice-9 match)
  26. #:use-module (language cps)
  27. #:use-module (language cps intmap)
  28. #:use-module (language cps utils)
  29. #:use-module (language cps with-cps)
  30. #:use-module (system base target)
  31. #:use-module (system base types internal)
  32. #:export (lower-primcalls))
  33. (define *primcall-lowerers* (make-hash-table))
  34. (define-syntax-rule (define-primcall-lowerer* name proc)
  35. (hashq-set! *primcall-lowerers* 'name proc))
  36. (define-syntax-rule (define-primcall-lowerer (name cps k src param-pat args-pat)
  37. body ...)
  38. (define-primcall-lowerer* name
  39. (lambda (cps k src param args)
  40. (match (cons param args)
  41. ((param-pat . args-pat)
  42. body ...)))))
  43. (define *branching-primcall-lowerers* (make-hash-table))
  44. (define-syntax-rule (define-branching-primcall-lowerer* name proc)
  45. (hashq-set! *branching-primcall-lowerers* 'name proc))
  46. (define-syntax-rule (define-branching-primcall-lowerer
  47. (name cps kf kt src param-pat args-pat)
  48. body ...)
  49. (define-branching-primcall-lowerer* name
  50. (lambda (cps kf kt src param args)
  51. (match (cons param args)
  52. ((param-pat . args-pat)
  53. body ...)))))
  54. (define-syntax-rule (define-branching-primcall-alias def use ...)
  55. (let ((proc (or (hashq-ref *branching-primcall-lowerers* 'def)
  56. (error "def not found" 'def))))
  57. (hashq-set! *branching-primcall-lowerers* 'use proc)
  58. ...))
  59. ;; precondition: v is vector. result is u64
  60. (define-primcall-lowerer (vector-length cps k src #f (v))
  61. (with-cps cps
  62. (letv w0 ulen)
  63. (letk kassume
  64. ($kargs ('ulen) (ulen)
  65. ($continue k src
  66. ($primcall 'assume-u64 `(0 . ,(target-max-vector-length)) (ulen)))))
  67. (letk krsh
  68. ($kargs ('w0) (w0)
  69. ($continue kassume src ($primcall 'ursh/immediate 8 (w0)))))
  70. (build-term
  71. ($continue krsh src
  72. ($primcall 'word-ref/immediate '(vector . 0) (v))))))
  73. ;; precondition: v is vector, uidx is u64 in range
  74. (define-primcall-lowerer (vector-ref cps k src #f (v uidx))
  75. (with-cps cps
  76. (letv upos)
  77. (letk kref ($kargs ('pos) (upos)
  78. ($continue k src
  79. ($primcall 'scm-ref 'vector (v upos)))))
  80. (build-term
  81. ($continue kref src
  82. ($primcall 'uadd/immediate 1 (uidx))))))
  83. ;; precondition: v is vector, idx is in range
  84. (define-primcall-lowerer (vector-ref/immediate cps k src idx (v))
  85. (let ((pos (1+ idx)))
  86. (with-cps cps
  87. (build-term
  88. ($continue k src
  89. ($primcall 'scm-ref/immediate `(vector . ,pos) (v)))))))
  90. ;; precondition: v is vector, uidx is u64 and is in range
  91. (define-primcall-lowerer (vector-set! cps k src #f (v uidx val))
  92. (with-cps cps
  93. (letv upos)
  94. (letk kset ($kargs ('pos) (upos)
  95. ($continue k src
  96. ($primcall 'scm-set! 'vector (v upos val)))))
  97. (build-term
  98. ($continue kset src
  99. ($primcall 'uadd/immediate 1 (uidx))))))
  100. ;; precondition: v is vector, idx is in range
  101. (define-primcall-lowerer (vector-set!/immediate cps k src idx (v val))
  102. (let ((pos (1+ idx)))
  103. (with-cps cps
  104. (build-term
  105. ($continue k src
  106. ($primcall 'scm-set!/immediate `(vector . ,pos) (v val)))))))
  107. (define-primcall-lowerer (allocate-vector/immediate cps k src size ())
  108. (define nwords (1+ size))
  109. (unless (and (exact-integer? size) (<= 0 size (target-max-vector-length)))
  110. (error "precondition failed" size))
  111. (with-cps cps
  112. (letv v w0)
  113. (letk kdone
  114. ($kargs () ()
  115. ($continue k src ($values (v)))))
  116. (letk ktag1
  117. ($kargs ('w0) (w0)
  118. ($continue kdone src
  119. ($primcall 'word-set!/immediate '(vector . 0) (v w0)))))
  120. (letk ktag0
  121. ($kargs ('v) (v)
  122. ($continue ktag1 src
  123. ($primcall 'load-u64 (+ %tc7-vector (ash size 8)) ()))))
  124. (build-term
  125. ($continue ktag0 src
  126. ($primcall 'allocate-words/immediate `(vector . ,nwords) ())))))
  127. ;; precondition: usize is u64 within range
  128. (define-primcall-lowerer (allocate-vector cps k src #f (usize))
  129. (with-cps cps
  130. (letv nwords v w0-high w0)
  131. (letk kdone
  132. ($kargs () ()
  133. ($continue k src ($values (v)))))
  134. (letk ktag2
  135. ($kargs ('w0) (w0)
  136. ($continue kdone src
  137. ($primcall 'word-set!/immediate '(vector . 0) (v w0)))))
  138. (letk ktag1
  139. ($kargs ('w0-high) (w0-high)
  140. ($continue ktag2 src
  141. ($primcall 'uadd/immediate %tc7-vector (w0-high)))))
  142. (letk ktag0
  143. ($kargs ('v) (v)
  144. ($continue ktag1 src
  145. ($primcall 'ulsh/immediate 8 (usize)))))
  146. (letk kalloc
  147. ($kargs ('nwords) (nwords)
  148. ($continue ktag0 src
  149. ($primcall 'allocate-words 'vector (nwords)))))
  150. (build-term
  151. ($continue kalloc src
  152. ;; Header word.
  153. ($primcall 'uadd/immediate 1 (usize))))))
  154. ;; precondition: none
  155. (define-primcall-lowerer (cons cps k src #f (head tail))
  156. (with-cps cps
  157. (letv pair)
  158. (letk kdone
  159. ($kargs () ()
  160. ($continue k src ($values (pair)))))
  161. (letk ktail
  162. ($kargs () ()
  163. ($continue kdone src
  164. ($primcall 'scm-set!/immediate '(pair . 1) (pair tail)))))
  165. (letk khead
  166. ($kargs ('pair) (pair)
  167. ($continue ktail src
  168. ($primcall 'scm-set!/immediate '(pair . 0) (pair head)))))
  169. (build-term
  170. ($continue khead src
  171. ($primcall 'allocate-words/immediate '(pair . 2) ())))))
  172. ;; precondition: pair is pair
  173. (define-primcall-lowerer (car cps k src #f (pair))
  174. (with-cps cps
  175. (build-term
  176. ($continue k src
  177. ($primcall 'scm-ref/immediate '(pair . 0) (pair))))))
  178. ;; precondition: pair is pair
  179. (define-primcall-lowerer (cdr cps k src #f (pair))
  180. (with-cps cps
  181. (build-term
  182. ($continue k src
  183. ($primcall 'scm-ref/immediate '(pair . 1) (pair))))))
  184. ;; precondition: pair is mutable pair
  185. (define-primcall-lowerer (set-car! cps k src #f (pair val))
  186. (with-cps cps
  187. (build-term
  188. ($continue k src
  189. ($primcall 'scm-set!/immediate '(pair . 0) (pair val))))))
  190. ;; precondition: pair is mutable pair
  191. (define-primcall-lowerer (set-cdr! cps k src #f (pair val))
  192. (with-cps cps
  193. (build-term
  194. ($continue k src
  195. ($primcall 'scm-set!/immediate '(pair . 1) (pair val))))))
  196. ;; precondition: none
  197. (define-primcall-lowerer (box cps k src #f (val))
  198. (with-cps cps
  199. (letv obj tag)
  200. (letk kdone
  201. ($kargs () ()
  202. ($continue k src ($values (obj)))))
  203. (letk kval
  204. ($kargs () ()
  205. ($continue kdone src
  206. ($primcall 'scm-set!/immediate '(box . 1) (obj val)))))
  207. (letk ktag1
  208. ($kargs ('tag) (tag)
  209. ($continue kval src
  210. ($primcall 'word-set!/immediate '(box . 0) (obj tag)))))
  211. (letk ktag0
  212. ($kargs ('obj) (obj)
  213. ($continue ktag1 src
  214. ($primcall 'load-u64 %tc7-variable ()))))
  215. (build-term
  216. ($continue ktag0 src
  217. ($primcall 'allocate-words/immediate '(box . 2) ())))))
  218. ;; precondition: box is box. note: no checking for unbound!
  219. (define-primcall-lowerer (box-ref cps k src #f (box))
  220. (with-cps cps
  221. (build-term
  222. ($continue k src
  223. ($primcall 'scm-ref/immediate '(box . 1) (box))))))
  224. ;; precondition: box is box
  225. (define-primcall-lowerer (box-set! cps k src #f (box val))
  226. (with-cps cps
  227. (build-term
  228. ($continue k src
  229. ($primcall 'scm-set!/immediate '(box . 1) (box val))))))
  230. ;; precondition: struct is a struct.
  231. (define-primcall-lowerer (struct-vtable cps k src #f (struct))
  232. (with-cps cps
  233. (build-term
  234. ($continue k src
  235. ($primcall 'scm-ref/tag 'struct (struct))))))
  236. ;; precondition: vtable is a vtable. result is u64
  237. (define-primcall-lowerer (vtable-size cps k src #f (vtable))
  238. (define vtable-index-size 5) ; FIXME: pull from struct.h
  239. (define vtable-offset-size (1+ vtable-index-size))
  240. (with-cps cps
  241. (letv rfields)
  242. (letk kassume
  243. ($kargs ('rfields) (rfields)
  244. ($continue k src
  245. ($primcall 'assume-u64 `(0 . ,(target-max-size-t/scm))
  246. (rfields)))))
  247. (build-term
  248. ($continue kassume src
  249. ($primcall 'word-ref/immediate
  250. `(struct . ,vtable-offset-size) (vtable))))))
  251. ;; precondition: vtable is a vtable.
  252. (define-branching-primcall-lowerer (vtable-vtable? cps kf kt src #f (vtable))
  253. (define vtable-index-flags 1) ; FIXME: pull from struct.h
  254. (define vtable-offset-flags (1+ vtable-index-flags))
  255. (define vtable-validated-mask #b11)
  256. (define vtable-validated-value #b11)
  257. (with-cps cps
  258. (letv flags res)
  259. (letk ktest
  260. ($kargs ('res) (res)
  261. ($branch kf kt src
  262. 'u64-imm-= vtable-validated-value (res))))
  263. (letk kflags
  264. ($kargs ('flags) (flags)
  265. ($continue ktest src
  266. ($primcall 'ulogand/immediate vtable-validated-mask (flags)))))
  267. (build-term
  268. ($continue kflags src
  269. ($primcall 'word-ref/immediate
  270. `(struct . ,vtable-offset-flags) (vtable))))))
  271. ;; precondition: vtable is a vtable.
  272. (define-branching-primcall-lowerer (vtable-has-unboxed-fields? cps kf kt src
  273. nfields (vtable))
  274. (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h
  275. (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields))
  276. (define (check-any-unboxed cps ptr word)
  277. (if (< (* word 32) nfields)
  278. (with-cps cps
  279. (letv idx bits)
  280. (let$ checkboxed (check-any-unboxed ptr (1+ word)))
  281. (letk kcheckboxed ($kargs () () ,checkboxed))
  282. (letk kcheck
  283. ($kargs ('bits) (bits)
  284. ($branch kt kcheckboxed src 'u64-imm-= 0 (bits))))
  285. (letk kword
  286. ($kargs ('idx) (idx)
  287. ($continue kcheck src
  288. ($primcall 'u32-ref 'bitmask (vtable ptr idx)))))
  289. (build-term
  290. ($continue kword src
  291. ($primcall 'load-u64 word ()))))
  292. (with-cps cps
  293. (build-term ($continue kf src ($values ()))))))
  294. (with-cps cps
  295. (letv ptr)
  296. (let$ checkboxed (check-any-unboxed ptr 0))
  297. (letk kcheckboxed ($kargs ('ptr) (ptr) ,checkboxed))
  298. (build-term
  299. ($continue kcheckboxed src
  300. ($primcall 'pointer-ref/immediate
  301. `(struct . ,vtable-offset-unboxed-fields)
  302. (vtable))))))
  303. ;; precondition: vtable is a vtable, no unboxed fields, nfields matches
  304. ;; vtable size.
  305. (define-primcall-lowerer (allocate-struct cps k src nfields (vtable))
  306. (define nwords (1+ nfields))
  307. (with-cps cps
  308. (letv s)
  309. (letk kdone
  310. ($kargs () () ($continue k src ($values (s)))))
  311. (letk ktag
  312. ($kargs ('s) (s)
  313. ($continue kdone src
  314. ($primcall 'scm-set!/tag 'struct (s vtable)))))
  315. (build-term
  316. ($continue ktag src
  317. ($primcall 'allocate-words/immediate `(struct . ,nwords) ())))))
  318. ;; precondition: vtable is vtable, idx less than vtable size
  319. (define-branching-primcall-lowerer (vtable-field-boxed? cps kf kt src idx (vtable))
  320. (define vtable-index-unboxed-fields 6) ; FIXME: pull from struct.h
  321. (define vtable-offset-unboxed-fields (1+ vtable-index-unboxed-fields))
  322. (with-cps cps
  323. (letv ptr word bits res)
  324. (letk ktest
  325. ($kargs ('res) (res)
  326. ($branch kf kt src 'u64-imm-= 0 (res))))
  327. (letk kbits
  328. ($kargs ('bits) (bits)
  329. ($continue ktest src
  330. ($primcall 'ulogand/immediate (ash 1 (logand idx 31)) (bits)))))
  331. (letk kword
  332. ($kargs ('word) (word)
  333. ($continue kbits src
  334. ($primcall 'u32-ref 'bitmask (vtable ptr word)))))
  335. (letk kptr
  336. ($kargs ('ptr) (ptr)
  337. ($continue kword src
  338. ($primcall 'load-u64 (ash idx -5) ()))))
  339. (build-term
  340. ($continue kptr src
  341. ($primcall 'pointer-ref/immediate
  342. `(struct . ,vtable-offset-unboxed-fields)
  343. (vtable))))))
  344. ;; precondition: struct a struct, idx in range, field unboxed.
  345. (define-primcall-lowerer (struct-ref cps k src idx (struct))
  346. (define pos (1+ idx)) ; get past vtable
  347. (with-cps cps
  348. (build-term
  349. ($continue k src
  350. ($primcall 'scm-ref/immediate `(struct . ,pos) (struct))))))
  351. ;; precondition: struct a struct, idx in range, field unboxed.
  352. (define-primcall-lowerer (struct-set! cps k src idx (struct val))
  353. (define pos (1+ idx)) ; get past vtable
  354. (with-cps cps
  355. (build-term
  356. ($continue k src
  357. ($primcall 'scm-set!/immediate `(struct . ,pos) (struct val))))))
  358. ;; precondition: bv is bytevector. result is ptr
  359. (define-primcall-lowerer (bv-contents cps k src #f (bv))
  360. (with-cps cps
  361. (build-term
  362. ($continue k src
  363. ($primcall 'pointer-ref/immediate '(bytevector . 2) (bv))))))
  364. ;; precondition: bv is bytevector. result u64
  365. (define-primcall-lowerer (bv-length cps k src #f (bv))
  366. (with-cps cps
  367. (letv ulen)
  368. (letk kassume
  369. ($kargs ('ulen) (ulen)
  370. ($continue k src
  371. ($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (ulen)))))
  372. (build-term
  373. ($continue kassume src
  374. ($primcall 'word-ref/immediate '(bytevector . 1) (bv))))))
  375. ;; precondition: str is a string. result u64
  376. (define-primcall-lowerer (string-length cps k src #f (str))
  377. (with-cps cps
  378. (letv ulen)
  379. (letk kassume
  380. ($kargs ('ulen) (ulen)
  381. ($continue k src
  382. ($primcall 'assume-u64 `(0 . ,(target-max-size-t)) (ulen)))))
  383. (build-term
  384. ($continue kassume src
  385. ($primcall 'word-ref/immediate '(string . 3) (str))))))
  386. ;; precondition: s a string, uidx in range. result unboxed.
  387. (define-primcall-lowerer (string-ref cps k src #f (s uidx))
  388. (define stringbuf-f-wide #x400)
  389. (with-cps cps
  390. (letv start upos buf ptr tag bits uwpos u32)
  391. (letk kassume
  392. ($kargs ('u32) (u32)
  393. ($continue k src
  394. ($primcall 'assume-u64 '(0 . #xffffff) (u32)))))
  395. (letk kwideref
  396. ($kargs ('uwpos) (uwpos)
  397. ($continue kassume src
  398. ($primcall 'u32-ref 'stringbuf (buf ptr uwpos)))))
  399. (letk kwide
  400. ($kargs () ()
  401. ($continue kwideref src
  402. ($primcall 'ulsh/immediate 2 (upos)))))
  403. (letk knarrow
  404. ($kargs () ()
  405. ($continue k src
  406. ($primcall 'u8-ref 'stringbuf (buf ptr upos)))))
  407. (letk kcmp
  408. ($kargs ('bits) (bits)
  409. ($branch kwide knarrow src 'u64-imm-= 0 (bits))))
  410. (letk ktag
  411. ($kargs ('tag) (tag)
  412. ($continue kcmp src
  413. ($primcall 'ulogand/immediate stringbuf-f-wide (tag)))))
  414. (letk kptr
  415. ($kargs ('ptr) (ptr)
  416. ($continue ktag src
  417. ($primcall 'word-ref/immediate '(stringbuf . 0) (buf)))))
  418. (letk kwidth
  419. ($kargs ('buf) (buf)
  420. ($continue kptr src
  421. ($primcall 'tail-pointer-ref/immediate '(stringbuf . 2) (buf)))))
  422. (letk kbuf
  423. ($kargs ('upos) (upos)
  424. ($continue kwidth src
  425. ($primcall 'scm-ref/immediate '(string . 1) (s)))))
  426. (letk kadd
  427. ($kargs ('start) (start)
  428. ($continue kbuf src
  429. ($primcall 'uadd #f (start uidx)))))
  430. (build-term
  431. ($continue kadd src
  432. ($primcall 'word-ref/immediate '(string . 2) (s))))))
  433. ;; precondition: sym is a symbol.
  434. (define-primcall-lowerer (symbol-hash cps k src #f (sym))
  435. (with-cps cps
  436. (build-term
  437. ($continue k src
  438. ($primcall 'word-ref/immediate '(symbol . 2) (sym))))))
  439. ;; precondition: none.
  440. (define-primcall-lowerer (make-atomic-box cps k src #f (val))
  441. (with-cps cps
  442. (letv obj tag)
  443. (letk kdone
  444. ($kargs () ()
  445. ($continue k src ($values (obj)))))
  446. (letk kval
  447. ($kargs () ()
  448. ($continue kdone src
  449. ($primcall 'atomic-scm-set!/immediate '(atomic-box . 1) (obj val)))))
  450. (letk ktag1
  451. ($kargs ('tag) (tag)
  452. ($continue kval src
  453. ($primcall 'word-set!/immediate '(atomic-box . 0) (obj tag)))))
  454. (letk ktag0
  455. ($kargs ('obj) (obj)
  456. ($continue ktag1 src
  457. ($primcall 'load-u64 %tc7-atomic-box ()))))
  458. (build-term
  459. ($continue ktag0 src
  460. ($primcall 'allocate-words/immediate '(atomic-box . 2) ())))))
  461. ;; precondition: x is atomic box
  462. (define-primcall-lowerer (atomic-box-ref cps k src #f (x))
  463. (with-cps cps
  464. (build-term
  465. ($continue k src
  466. ($primcall 'atomic-scm-ref/immediate '(atomic-box . 1) (x))))))
  467. ;; precondition: x is atomic box
  468. (define-primcall-lowerer (atomic-box-set! cps k src #f (x val))
  469. (with-cps cps
  470. (build-term
  471. ($continue k src
  472. ($primcall 'atomic-scm-set!/immediate '(atomic-box . 1)
  473. (x val))))))
  474. ;; precondition: x is atomic box
  475. (define-primcall-lowerer (atomic-box-swap! cps k src param (x val))
  476. (with-cps cps
  477. (build-term
  478. ($continue k src
  479. ($primcall 'atomic-scm-swap!/immediate '(atomic-box . 1)
  480. (x val))))))
  481. ;; precondition: x is atomic box
  482. (define-primcall-lowerer (atomic-box-compare-and-swap! cps k src param (x expected desired))
  483. (with-cps cps
  484. (build-term
  485. ($continue k src
  486. ($primcall 'atomic-scm-compare-and-swap!/immediate '(atomic-box . 1)
  487. (x expected desired))))))
  488. ;; precondition: code is result of $code
  489. (define-primcall-lowerer (make-closure cps k src nfree (code))
  490. (define nwords (+ nfree 2))
  491. (with-cps cps
  492. (letv closure tag)
  493. (letk kdone
  494. ($kargs () ()
  495. ($continue k src ($values (closure)))))
  496. (letk kinit
  497. ($kargs () ()
  498. ($continue kdone src
  499. ($primcall 'word-set!/immediate '(closure . 1) (closure code)))))
  500. (letk ktag1
  501. ($kargs ('tag) (tag)
  502. ($continue kinit src
  503. ($primcall 'word-set!/immediate '(closure . 0) (closure tag)))))
  504. (letk ktag0
  505. ($kargs ('closure) (closure)
  506. ($continue ktag1 src
  507. ($primcall 'load-u64 (+ %tc7-program (ash nfree 16)) ()))))
  508. (build-term
  509. ($continue ktag0 src
  510. ($primcall 'allocate-words/immediate `(closure . ,nwords) ())))))
  511. ;; precondition: closure is closure, idx is in range
  512. (define-primcall-lowerer (closure-ref cps k src (idx . nfree) (closure))
  513. (let ((pos (+ idx 2)))
  514. (with-cps cps
  515. (build-term
  516. ($continue k src
  517. ($primcall 'scm-ref/immediate `(closure . ,pos) (closure)))))))
  518. ;; precondition: closure is clodure, idx is in range
  519. (define-primcall-lowerer (closure-set! cps k src (idx . nfree) (closure val))
  520. (let ((pos (+ idx 2)))
  521. (with-cps cps
  522. (build-term
  523. ($continue k src
  524. ($primcall 'scm-set!/immediate `(closure . ,pos) (closure val)))))))
  525. (define-primcall-lowerer (f64->scm cps k src #f (f64))
  526. (with-cps cps
  527. (letv scm tag ptr uidx)
  528. (letk kdone ($kargs () ()
  529. ($continue k src ($values (scm)))))
  530. (letk kinit ($kargs ('uidx) (uidx)
  531. ($continue kdone src
  532. ($primcall 'f64-set! 'flonum (scm ptr uidx f64)))))
  533. (letk kidx ($kargs ('ptr) (ptr)
  534. ($continue kinit src ($primcall 'load-u64 0 ()))))
  535. (letk kptr ($kargs () ()
  536. ($continue kidx src
  537. ($primcall 'tail-pointer-ref/immediate
  538. `(flonum . ,(match (target-word-size)
  539. (4 2)
  540. (8 1)))
  541. (scm)))))
  542. (letk ktag1 ($kargs ('tag) (tag)
  543. ($continue kptr src
  544. ($primcall 'word-set!/immediate '(flonum . 0) (scm tag)))))
  545. (letk ktag0 ($kargs ('scm) (scm)
  546. ($continue ktag1 src
  547. ($primcall 'load-u64 %tc16-flonum ()))))
  548. (build-term
  549. ($continue ktag0 src
  550. ($primcall 'allocate-pointerless-words/immediate
  551. `(flonum . ,(match (target-word-size)
  552. (4 4)
  553. (8 2)))
  554. ())))))
  555. (define-primcall-lowerer (keyword->symbol cps k src #f (kw))
  556. (with-cps cps
  557. (build-term
  558. ($continue k src
  559. ($primcall 'scm-ref/immediate '(keyword . 1) (kw))))))
  560. (define-branching-primcall-lowerer (procedure? cps kf kt src #f (x))
  561. (with-cps cps
  562. (letv procedure? result)
  563. (letk kresult
  564. ($kargs ('result) (result)
  565. ($branch kt kf src 'eq-constant? #f (result))))
  566. (letk krecv
  567. ($kreceive '(result) '() kresult))
  568. (letk kcall
  569. ($kargs ('procedure?) (procedure?)
  570. ($continue krecv src
  571. ($call procedure? (x)))))
  572. (build-term
  573. ($continue kcall src ($prim 'procedure?)))))
  574. (define-branching-primcall-lowerer (number? cps kf kt src #f (x))
  575. (with-cps cps
  576. (letk kheap-num
  577. ($kargs () ()
  578. ($branch kf kt src 'heap-number? #f (x))))
  579. (letk kheap
  580. ($kargs () ()
  581. ($branch kf kheap-num src 'heap-object? #f (x))))
  582. (build-term
  583. ($branch kheap kt src 'fixnum? #f (x)))))
  584. (define-branching-primcall-alias number? complex?)
  585. (define-branching-primcall-lowerer (real? cps kf kt src #f (x))
  586. (with-cps cps
  587. (letk kcomp
  588. ($kargs () ()
  589. ($branch kt kf src 'compnum? #f (x))))
  590. (letk kheap-num
  591. ($kargs () ()
  592. ($branch kf kcomp src 'heap-number? #f (x))))
  593. (letk kheap
  594. ($kargs () ()
  595. ($branch kf kheap-num src 'heap-object? #f (x))))
  596. (build-term
  597. ($branch kheap kt src 'fixnum? #f (x)))))
  598. (define-branching-primcall-lowerer (rational? cps kf kt src #f (x))
  599. (with-cps cps
  600. (letv res prim)
  601. (letk ktest
  602. ($kargs ('res) (res)
  603. ($branch kt kf src 'false? #f (res))))
  604. (letk krecv
  605. ($kreceive '(val) #f ktest))
  606. (letk kcall
  607. ($kargs ('prim) (prim)
  608. ($continue krecv src ($call prim (x)))))
  609. (build-term
  610. ($continue kcall src ($prim 'rational?)))))
  611. (define-branching-primcall-lowerer (integer? cps kf kt src #f (x))
  612. (with-cps cps
  613. (letv res prim)
  614. (letk ktest
  615. ($kargs ('res) (res)
  616. ($branch kt kf src 'false? #f (res))))
  617. (letk krecv
  618. ($kreceive '(val) #f ktest))
  619. (letk kcall
  620. ($kargs ('prim) (prim)
  621. ($continue krecv src ($call prim (x)))))
  622. (build-term
  623. ($continue kcall src ($prim 'integer?)))))
  624. (define-branching-primcall-lowerer (exact-integer? cps kf kt src #f (x))
  625. (with-cps cps
  626. (letk kbig
  627. ($kargs () ()
  628. ($branch kf kt src 'bignum? #f (x))))
  629. (letk kheap
  630. ($kargs () ()
  631. ($branch kf kbig src 'heap-object? #f (x))))
  632. (build-term
  633. ($branch kheap kt src 'fixnum? #f (x)))))
  634. (define-branching-primcall-lowerer (exact? cps kf kt src #f (x))
  635. (with-cps cps
  636. (letk kfrac
  637. ($kargs () ()
  638. ($branch kf kt src 'fracnum? #f (x))))
  639. (letk kbig
  640. ($kargs () ()
  641. ($branch kfrac kt src 'bignum? #f (x))))
  642. (build-term
  643. ($branch kbig kt src 'fixnum? #f (x)))))
  644. (define-branching-primcall-lowerer (inexact? cps kf kt src #f (x))
  645. (with-cps cps
  646. (letk kcomp
  647. ($kargs () ()
  648. ($branch kf kt src 'compnum? #f (x))))
  649. (letk kflo
  650. ($kargs () ()
  651. ($branch kcomp kt src 'flonum? #f (x))))
  652. (build-term
  653. ($branch kflo kf src 'fixnum? #f (x)))))
  654. (define (lower-primcalls cps)
  655. (with-fresh-name-state cps
  656. (persistent-intmap
  657. (intmap-fold
  658. (lambda (label cont cps)
  659. (match cont
  660. (($ $kargs names vars
  661. ($ $continue k src ($ $calli)))
  662. (error "$calli unsupported by guile-vm backend"))
  663. (($ $kargs names vars
  664. ($ $continue k src ($ $primcall op param args)))
  665. (match (hashq-ref *primcall-lowerers* op)
  666. (#f cps)
  667. (lower
  668. (with-cps cps
  669. (let$ term (lower k src param args))
  670. (setk label ($kargs names vars ,term))))))
  671. (($ $kargs names vars
  672. ($ $branch kf kt src op param args))
  673. (match (hashq-ref *branching-primcall-lowerers* op)
  674. (#f cps)
  675. (lower
  676. (with-cps cps
  677. (let$ term (lower kf kt src param args))
  678. (setk label ($kargs names vars ,term))))))
  679. (_ cps)))
  680. cps cps))))