compile-bytecode.scm 31 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690
  1. ;;; Continuation-passing style (CPS) intermediate language (IL)
  2. ;; Copyright (C) 2013-2021, 2023 Free Software Foundation, Inc.
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 3 of the License, or (at your option) any later version.
  7. ;;;;
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;;
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;; Commentary:
  17. ;;;
  18. ;;; Compiling CPS to bytecode. The result is in the bytecode language,
  19. ;;; which happens to be an ELF image as a bytecode.
  20. ;;;
  21. ;;; Code:
  22. (define-module (language cps compile-bytecode)
  23. #:use-module (ice-9 match)
  24. #:use-module (srfi srfi-1)
  25. #:use-module (language cps)
  26. #:use-module (language cps slot-allocation)
  27. #:use-module (language cps utils)
  28. #:use-module (language cps intmap)
  29. #:use-module (language cps intset)
  30. #:use-module (system vm assembler)
  31. #:use-module (system base types internal)
  32. #:export (compile-bytecode))
  33. (define (kw-arg-ref args kw default)
  34. (match (memq kw args)
  35. ((_ val . _) val)
  36. (_ default)))
  37. (define (intmap-for-each f map)
  38. (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*))
  39. (define (intmap-select map set)
  40. (persistent-intmap
  41. (intset-fold
  42. (lambda (k out)
  43. (intmap-add! out k (intmap-ref map k)))
  44. set
  45. empty-intmap)))
  46. ;; Any $values expression that continues to a $kargs and causes no
  47. ;; shuffles is a forwarding label. $kreceive conts also forward to
  48. ;; their continuations.
  49. (define (compute-forwarding-labels cps allocation)
  50. (fixpoint
  51. (lambda (forwarding-map)
  52. (intmap-fold (lambda (label target forwarding-map)
  53. (let ((new-target (intmap-ref forwarding-map target
  54. (lambda (target) target))))
  55. (if (eqv? target new-target)
  56. forwarding-map
  57. (intmap-replace forwarding-map label new-target))))
  58. forwarding-map forwarding-map))
  59. (intmap-fold (lambda (label cont forwarding-labels)
  60. (match cont
  61. (($ $kargs _ _ ($ $continue k _ ($ $values)))
  62. (match (lookup-send-parallel-moves label allocation)
  63. (()
  64. (match (intmap-ref cps k)
  65. (($ $ktail) forwarding-labels)
  66. (_ (intmap-add forwarding-labels label k))))
  67. (_ forwarding-labels)))
  68. (($ $kreceive arity kargs)
  69. (intmap-add forwarding-labels label kargs))
  70. (_ forwarding-labels)))
  71. cps empty-intmap)))
  72. (define (compile-function cps asm opts)
  73. (let* ((allocation (allocate-slots cps #:precolor-calls?
  74. (kw-arg-ref opts #:precolor-calls? #t)))
  75. (forwarding-labels (compute-forwarding-labels cps allocation))
  76. (frame-size (lookup-nlocals allocation)))
  77. (define (forward-label k)
  78. (intmap-ref forwarding-labels k (lambda (k) k)))
  79. (define (elide-cont? label)
  80. (match (intmap-ref forwarding-labels label (lambda (_) #f))
  81. (#f #f)
  82. (target (not (eqv? label target)))))
  83. (define (maybe-slot sym)
  84. (lookup-maybe-slot sym allocation))
  85. (define (slot sym)
  86. (lookup-slot sym allocation))
  87. (define (from-sp var)
  88. (- frame-size 1 var))
  89. (define (maybe-mov dst src)
  90. (unless (= dst src)
  91. (emit-mov asm (from-sp dst) (from-sp src))))
  92. (define (emit-moves moves)
  93. (for-each (match-lambda
  94. ((src . dst)
  95. (emit-mov asm (from-sp dst) (from-sp src))))
  96. moves))
  97. (define (compile-tail nlocals emit-tail)
  98. (unless (= frame-size nlocals)
  99. (emit-reset-frame asm nlocals))
  100. (emit-handle-interrupts asm)
  101. (emit-tail asm))
  102. (define (compile-receive label proc-slot cont)
  103. (define (shuffle-results)
  104. (let lp ((moves (lookup-receive-parallel-moves label allocation))
  105. (reset-frame? #f))
  106. (cond
  107. ((and (not reset-frame?)
  108. (and-map (match-lambda
  109. ((src . dst)
  110. (and (< src frame-size) (< dst frame-size))))
  111. moves))
  112. (emit-reset-frame asm frame-size)
  113. (emit-moves moves))
  114. (else
  115. (match moves
  116. (() #t)
  117. (((src . dst) . moves)
  118. (emit-fmov asm dst src)
  119. (lp moves reset-frame?)))))))
  120. (match cont
  121. (($ $kargs)
  122. (shuffle-results))
  123. (($ $kreceive ($ $arity req () rest () #f) kargs)
  124. (let ((nreq (length req))
  125. (rest-var (and rest
  126. (match (intmap-ref cps kargs)
  127. (($ $kargs names (_ ... rest))
  128. rest)))))
  129. (cond
  130. ((and (= 1 nreq) rest-var (not (maybe-slot rest-var))
  131. (match (lookup-receive-parallel-moves label allocation)
  132. ((((? (lambda (src) (= src proc-slot)) src)
  133. . dst)) dst)
  134. (_ #f)))
  135. ;; A common case: one required live return value,
  136. ;; ignoring any additional values.
  137. => (lambda (dst)
  138. (emit-receive asm dst proc-slot frame-size)))
  139. (else
  140. (unless (and (zero? nreq) rest-var)
  141. (emit-receive-values asm proc-slot (->bool rest-var) nreq))
  142. (when (and rest-var (maybe-slot rest-var))
  143. (emit-bind-rest asm (+ proc-slot nreq)))
  144. (shuffle-results)))))))
  145. (define (compile-value exp dst)
  146. (match exp
  147. (($ $primcall (or 's64->u64 'u64->s64) #f (arg))
  148. (maybe-mov dst (slot arg)))
  149. (($ $const exp)
  150. (emit-load-constant asm (from-sp dst) exp))
  151. (($ $const-fun k)
  152. (emit-load-static-procedure asm (from-sp dst) k))
  153. (($ $code k)
  154. (emit-load-label asm (from-sp dst) k))
  155. (($ $primcall 'current-module)
  156. (emit-current-module asm (from-sp dst)))
  157. (($ $primcall 'current-thread)
  158. (emit-current-thread asm (from-sp dst)))
  159. (($ $primcall 'define! #f (mod sym))
  160. (emit-define! asm (from-sp dst)
  161. (from-sp (slot mod)) (from-sp (slot sym))))
  162. (($ $primcall 'resolve (bound?) (name))
  163. (emit-resolve asm (from-sp dst) bound? (from-sp (slot name))))
  164. (($ $primcall 'allocate-words annotation (nfields))
  165. (emit-allocate-words asm (from-sp dst) (from-sp (slot nfields))))
  166. (($ $primcall 'allocate-words/immediate (annotation . nfields))
  167. (emit-allocate-words/immediate asm (from-sp dst) nfields))
  168. (($ $primcall 'allocate-pointerless-words annotation (nfields))
  169. (emit-allocate-pointerless-words asm (from-sp dst)
  170. (from-sp (slot nfields))))
  171. (($ $primcall 'allocate-pointerless-words/immediate
  172. (annotation . nfields))
  173. (emit-allocate-pointerless-words/immediate asm (from-sp dst) nfields))
  174. (($ $primcall 'scm-ref annotation (obj idx))
  175. (emit-scm-ref asm (from-sp dst) (from-sp (slot obj))
  176. (from-sp (slot idx))))
  177. (($ $primcall 'scm-ref/tag annotation (obj))
  178. (let ((tag (match annotation
  179. ('pair %tc1-pair)
  180. ('struct %tc3-struct))))
  181. (emit-scm-ref/tag asm (from-sp dst) (from-sp (slot obj)) tag)))
  182. (($ $primcall 'scm-ref/immediate (annotation . idx) (obj))
  183. (emit-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
  184. (($ $primcall 'word-ref annotation (obj idx))
  185. (emit-word-ref asm (from-sp dst) (from-sp (slot obj))
  186. (from-sp (slot idx))))
  187. (($ $primcall 'word-ref/immediate (annotation . idx) (obj))
  188. (emit-word-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
  189. (($ $primcall 'pointer-ref/immediate (annotation . idx) (obj))
  190. (emit-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj)) idx))
  191. (($ $primcall 'tail-pointer-ref/immediate (annotation . idx) (obj))
  192. (emit-tail-pointer-ref/immediate asm (from-sp dst) (from-sp (slot obj))
  193. idx))
  194. (($ $primcall 'cache-ref key ())
  195. (emit-cache-ref asm (from-sp dst) key))
  196. (($ $primcall 'resolve-module public? (name))
  197. (emit-resolve-module asm (from-sp dst) (from-sp (slot name)) public?))
  198. (($ $primcall 'module-variable #f (mod name))
  199. (emit-module-variable asm (from-sp dst) (from-sp (slot mod))
  200. (from-sp (slot name))))
  201. (($ $primcall 'lookup #f (mod name))
  202. (emit-lookup asm (from-sp dst) (from-sp (slot mod))
  203. (from-sp (slot name))))
  204. (($ $primcall 'lookup-bound #f (mod name))
  205. (emit-lookup-bound asm (from-sp dst) (from-sp (slot mod))
  206. (from-sp (slot name))))
  207. (($ $primcall 'lookup-bound-public (mod name) ())
  208. (let ((name (symbol->string name)))
  209. (emit-lookup-bound-public asm (from-sp dst) mod name)))
  210. (($ $primcall 'lookup-bound-private (mod name) ())
  211. (let ((name (symbol->string name)))
  212. (emit-lookup-bound-private asm (from-sp dst) mod name)))
  213. (($ $primcall 'add/immediate y (x))
  214. (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) y))
  215. (($ $primcall 'sub/immediate y (x))
  216. (emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) y))
  217. (($ $primcall 'uadd/immediate y (x))
  218. (emit-uadd/immediate asm (from-sp dst) (from-sp (slot x)) y))
  219. (($ $primcall 'usub/immediate y (x))
  220. (emit-usub/immediate asm (from-sp dst) (from-sp (slot x)) y))
  221. (($ $primcall 'umul/immediate y (x))
  222. (emit-umul/immediate asm (from-sp dst) (from-sp (slot x)) y))
  223. (($ $primcall 'rsh #f (x y))
  224. (emit-rsh asm (from-sp dst) (from-sp (slot x)) (from-sp (slot y))))
  225. (($ $primcall 'lsh #f (x y))
  226. (emit-lsh asm (from-sp dst) (from-sp (slot x)) (from-sp (slot y))))
  227. (($ $primcall 'rsh/immediate y (x))
  228. (emit-rsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
  229. (($ $primcall 'lsh/immediate y (x))
  230. (emit-lsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
  231. (($ $primcall 'ursh/immediate y (x))
  232. (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x)) y))
  233. (($ $primcall 'srsh/immediate y (x))
  234. (emit-srsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
  235. (($ $primcall 'ulsh/immediate y (x))
  236. (emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x)) y))
  237. (($ $primcall 'ulogand/immediate y (x))
  238. (emit-ulogand/immediate asm (from-sp dst) (from-sp (slot x)) y))
  239. (($ $primcall 'builtin-ref idx ())
  240. (emit-builtin-ref asm (from-sp dst) idx))
  241. (($ $primcall 'scm->f64 #f (src))
  242. (emit-scm->f64 asm (from-sp dst) (from-sp (slot src))))
  243. (($ $primcall 'load-f64 val ())
  244. (emit-load-f64 asm (from-sp dst) val))
  245. (($ $primcall 'scm->u64 #f (src))
  246. (emit-scm->u64 asm (from-sp dst) (from-sp (slot src))))
  247. (($ $primcall 'scm->u64/truncate #f (src))
  248. (emit-scm->u64/truncate asm (from-sp dst) (from-sp (slot src))))
  249. (($ $primcall 'load-u64 val ())
  250. (emit-load-u64 asm (from-sp dst) val))
  251. (($ $primcall 'u64->scm #f (src))
  252. (emit-u64->scm asm (from-sp dst) (from-sp (slot src))))
  253. (($ $primcall 'scm->s64 #f (src))
  254. (emit-scm->s64 asm (from-sp dst) (from-sp (slot src))))
  255. (($ $primcall 'load-s64 val ())
  256. (emit-load-s64 asm (from-sp dst) val))
  257. (($ $primcall 's64->scm #f (src))
  258. (emit-s64->scm asm (from-sp dst) (from-sp (slot src))))
  259. (($ $primcall 'u8-ref ann (obj ptr idx))
  260. (emit-u8-ref asm (from-sp dst) (from-sp (slot ptr))
  261. (from-sp (slot idx))))
  262. (($ $primcall 's8-ref ann (obj ptr idx))
  263. (emit-s8-ref asm (from-sp dst) (from-sp (slot ptr))
  264. (from-sp (slot idx))))
  265. (($ $primcall 'u16-ref ann (obj ptr idx))
  266. (emit-u16-ref asm (from-sp dst) (from-sp (slot ptr))
  267. (from-sp (slot idx))))
  268. (($ $primcall 's16-ref ann (obj ptr idx))
  269. (emit-s16-ref asm (from-sp dst) (from-sp (slot ptr))
  270. (from-sp (slot idx))))
  271. (($ $primcall 'u32-ref ann (obj ptr idx))
  272. (emit-u32-ref asm (from-sp dst) (from-sp (slot ptr))
  273. (from-sp (slot idx))))
  274. (($ $primcall 's32-ref ann (obj ptr idx))
  275. (emit-s32-ref asm (from-sp dst) (from-sp (slot ptr))
  276. (from-sp (slot idx))))
  277. (($ $primcall 'u64-ref ann (obj ptr idx))
  278. (emit-u64-ref asm (from-sp dst) (from-sp (slot ptr))
  279. (from-sp (slot idx))))
  280. (($ $primcall 's64-ref ann (obj ptr idx))
  281. (emit-s64-ref asm (from-sp dst) (from-sp (slot ptr))
  282. (from-sp (slot idx))))
  283. (($ $primcall 'f32-ref ann (obj ptr idx))
  284. (emit-f32-ref asm (from-sp dst) (from-sp (slot ptr))
  285. (from-sp (slot idx))))
  286. (($ $primcall 'f64-ref ann (obj ptr idx))
  287. (emit-f64-ref asm (from-sp dst) (from-sp (slot ptr))
  288. (from-sp (slot idx))))
  289. (($ $primcall 'atomic-scm-ref/immediate (annotation . idx) (obj))
  290. (emit-atomic-scm-ref/immediate asm (from-sp dst) (from-sp (slot obj))
  291. idx))
  292. (($ $primcall 'atomic-scm-swap!/immediate (annotation . idx) (obj val))
  293. (emit-atomic-scm-swap!/immediate asm (from-sp dst) (from-sp (slot obj))
  294. idx (from-sp (slot val))))
  295. (($ $primcall 'atomic-scm-compare-and-swap!/immediate (annotation . idx)
  296. (obj expected desired))
  297. (emit-atomic-scm-compare-and-swap!/immediate
  298. asm (from-sp dst) (from-sp (slot obj)) idx (from-sp (slot expected))
  299. (from-sp (slot desired))))
  300. (($ $primcall 'untag-fixnum #f (src))
  301. (emit-untag-fixnum asm (from-sp dst) (from-sp (slot src))))
  302. (($ $primcall 'tag-fixnum #f (src))
  303. (emit-tag-fixnum asm (from-sp dst) (from-sp (slot src))))
  304. (($ $primcall 'untag-char #f (src))
  305. (emit-untag-char asm (from-sp dst) (from-sp (slot src))))
  306. (($ $primcall 'tag-char #f (src))
  307. (emit-tag-char asm (from-sp dst) (from-sp (slot src))))
  308. (($ $primcall name #f args)
  309. ;; FIXME: Inline all the cases.
  310. (emit-text asm `((,name ,(from-sp dst)
  311. ,@(map (compose from-sp slot) args)))))))
  312. (define (compile-effect exp)
  313. (match exp
  314. (($ $primcall 'cache-set! key (val))
  315. (emit-cache-set! asm key (from-sp (slot val))))
  316. (($ $primcall 'scm-set! annotation (obj idx val))
  317. (emit-scm-set! asm (from-sp (slot obj)) (from-sp (slot idx))
  318. (from-sp (slot val))))
  319. (($ $primcall 'scm-set!/tag annotation (obj val))
  320. (let ((tag (match annotation
  321. ('pair %tc1-pair)
  322. ('struct %tc3-struct))))
  323. (emit-scm-set!/tag asm (from-sp (slot obj)) tag
  324. (from-sp (slot val)))))
  325. (($ $primcall 'scm-set!/immediate (annotation . idx) (obj val))
  326. (emit-scm-set!/immediate asm (from-sp (slot obj)) idx
  327. (from-sp (slot val))))
  328. (($ $primcall 'word-set! annotation (obj idx val))
  329. (emit-word-set! asm (from-sp (slot obj)) (from-sp (slot idx))
  330. (from-sp (slot val))))
  331. (($ $primcall 'word-set!/immediate (annotation . idx) (obj val))
  332. (emit-word-set!/immediate asm (from-sp (slot obj)) idx
  333. (from-sp (slot val))))
  334. (($ $primcall 'pointer-set!/immediate (annotation . idx) (obj val))
  335. (emit-pointer-set!/immediate asm (from-sp (slot obj)) idx
  336. (from-sp (slot val))))
  337. (($ $primcall 'string-set! #f (string index char))
  338. (emit-string-set! asm (from-sp (slot string)) (from-sp (slot index))
  339. (from-sp (slot char))))
  340. (($ $primcall 'push-fluid #f (fluid val))
  341. (emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val))))
  342. (($ $primcall 'pop-fluid #f ())
  343. (emit-pop-fluid asm))
  344. (($ $primcall 'push-dynamic-state #f (state))
  345. (emit-push-dynamic-state asm (from-sp (slot state))))
  346. (($ $primcall 'pop-dynamic-state #f ())
  347. (emit-pop-dynamic-state asm))
  348. (($ $primcall 'wind #f (winder unwinder))
  349. (emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder))))
  350. (($ $primcall 'u8-set! ann (obj ptr idx val))
  351. (emit-u8-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
  352. (from-sp (slot val))))
  353. (($ $primcall 's8-set! ann (obj ptr idx val))
  354. (emit-s8-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
  355. (from-sp (slot val))))
  356. (($ $primcall 'u16-set! ann (obj ptr idx val))
  357. (emit-u16-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
  358. (from-sp (slot val))))
  359. (($ $primcall 's16-set! ann (obj ptr idx val))
  360. (emit-s16-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
  361. (from-sp (slot val))))
  362. (($ $primcall 'u32-set! ann (obj ptr idx val))
  363. (emit-u32-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
  364. (from-sp (slot val))))
  365. (($ $primcall 's32-set! ann (obj ptr idx val))
  366. (emit-s32-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
  367. (from-sp (slot val))))
  368. (($ $primcall 'u64-set! ann (obj ptr idx val))
  369. (emit-u64-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
  370. (from-sp (slot val))))
  371. (($ $primcall 's64-set! ann (obj ptr idx val))
  372. (emit-s64-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
  373. (from-sp (slot val))))
  374. (($ $primcall 'f32-set! ann (obj ptr idx val))
  375. (emit-f32-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
  376. (from-sp (slot val))))
  377. (($ $primcall 'f64-set! ann (obj ptr idx val))
  378. (emit-f64-set! asm (from-sp (slot ptr)) (from-sp (slot idx))
  379. (from-sp (slot val))))
  380. (($ $primcall 'unwind #f ())
  381. (emit-unwind asm))
  382. (($ $primcall 'fluid-set! #f (fluid value))
  383. (emit-fluid-set! asm (from-sp (slot fluid)) (from-sp (slot value))))
  384. (($ $primcall 'atomic-scm-set!/immediate (annotation . idx) (obj val))
  385. (emit-atomic-scm-set!/immediate asm (from-sp (slot obj)) idx
  386. (from-sp (slot val))))
  387. (($ $primcall 'instrument-loop #f ())
  388. (emit-instrument-loop asm)
  389. (emit-handle-interrupts asm))))
  390. (define (compile-throw op param args)
  391. (match (vector op param args)
  392. (#('throw #f (key args))
  393. (emit-throw asm (from-sp (slot key)) (from-sp (slot args))))
  394. (#('throw/value param (val))
  395. (emit-throw/value asm (from-sp (slot val)) param))
  396. (#('throw/value+data param (val))
  397. (emit-throw/value+data asm (from-sp (slot val)) param))
  398. (#('unreachable #f ())
  399. (emit-unreachable asm))))
  400. (define (compile-prompt label k kh escape? tag)
  401. (let ((receive-args (gensym "handler"))
  402. (proc-slot (lookup-call-proc-slot label allocation)))
  403. (emit-prompt asm (from-sp (slot tag)) escape? proc-slot
  404. receive-args)
  405. (emit-j asm k)
  406. (emit-label asm receive-args)
  407. (compile-receive label proc-slot (intmap-ref cps kh))
  408. (emit-j asm (forward-label kh))))
  409. (define (compile-test label next-label kf kt op param args)
  410. (define (prefer-true?)
  411. (if (< (max kt kf) label)
  412. ;; Two backwards branches. Prefer
  413. ;; the nearest.
  414. (> kt kf)
  415. ;; Otherwise prefer a backwards
  416. ;; branch or a near jump.
  417. (< kt kf)))
  418. (define (emit-branch emit-jt emit-jf)
  419. (cond
  420. ((eq? kt next-label)
  421. (emit-jf asm kf))
  422. ((eq? kf next-label)
  423. (emit-jt asm kt))
  424. ((prefer-true?)
  425. (emit-jt asm kt)
  426. (emit-j asm kf))
  427. (else
  428. (emit-jf asm kf)
  429. (emit-j asm kt))))
  430. (define (unary op a)
  431. (op asm (from-sp (slot a)))
  432. (emit-branch emit-je emit-jne))
  433. (define (binary op emit-jt emit-jf a b)
  434. (op asm (from-sp (slot a)) (from-sp (slot b)))
  435. (emit-branch emit-jt emit-jf))
  436. (define (binary-test op a b)
  437. (binary op emit-je emit-jne a b))
  438. (define (binary-< emit-<? a b)
  439. (binary emit-<? emit-jl emit-jnl a b))
  440. (define (binary-<= emit-<? a b)
  441. (binary emit-<? emit-jge emit-jnge b a))
  442. (define (binary-test/imm op a b)
  443. (op asm (from-sp (slot a)) b)
  444. (emit-branch emit-je emit-jne))
  445. (define (binary-</imm op a b)
  446. (op asm (from-sp (slot a)) b)
  447. (emit-branch emit-jl emit-jnl))
  448. (match (vector op param args)
  449. ;; Immediate type tag predicates.
  450. (#('fixnum? #f (a)) (unary emit-fixnum? a))
  451. (#('heap-object? #f (a)) (unary emit-heap-object? a))
  452. (#('char? #f (a)) (unary emit-char? a))
  453. (#('eq-constant? imm (a)) (binary-test/imm emit-eq-immediate? a imm))
  454. (#('undefined? #f (a)) (unary emit-undefined? a))
  455. (#('null? #f (a)) (unary emit-null? a))
  456. (#('false? #f (a)) (unary emit-false? a))
  457. (#('nil? #f (a)) (unary emit-nil? a))
  458. ;; Heap type tag predicates.
  459. (#('pair? #f (a)) (unary emit-pair? a))
  460. (#('struct? #f (a)) (unary emit-struct? a))
  461. (#('symbol? #f (a)) (unary emit-symbol? a))
  462. (#('variable? #f (a)) (unary emit-variable? a))
  463. (#('vector? #f (a)) (unary emit-vector? a))
  464. (#('mutable-vector? #f (a)) (unary emit-mutable-vector? a))
  465. (#('immutable-vector? #f (a)) (unary emit-immutable-vector? a))
  466. (#('string? #f (a)) (unary emit-string? a))
  467. (#('heap-number? #f (a)) (unary emit-heap-number? a))
  468. (#('hash-table? #f (a)) (unary emit-hash-table? a))
  469. (#('pointer? #f (a)) (unary emit-pointer? a))
  470. (#('fluid? #f (a)) (unary emit-fluid? a))
  471. (#('stringbuf? #f (a)) (unary emit-stringbuf? a))
  472. (#('dynamic-state? #f (a)) (unary emit-dynamic-state? a))
  473. (#('frame? #f (a)) (unary emit-frame? a))
  474. (#('keyword? #f (a)) (unary emit-keyword? a))
  475. (#('atomic-box? #f (a)) (unary emit-atomic-box? a))
  476. (#('syntax? #f (a)) (unary emit-syntax? a))
  477. (#('program? #f (a)) (unary emit-program? a))
  478. (#('vm-continuation? #f (a)) (unary emit-vm-continuation? a))
  479. (#('bytevector? #f (a)) (unary emit-bytevector? a))
  480. (#('weak-set? #f (a)) (unary emit-weak-set? a))
  481. (#('weak-table? #f (a)) (unary emit-weak-table? a))
  482. (#('array? #f (a)) (unary emit-array? a))
  483. (#('bitvector? #f (a)) (unary emit-bitvector? a))
  484. (#('smob? #f (a)) (unary emit-smob? a))
  485. (#('port? #f (a)) (unary emit-port? a))
  486. (#('bignum? #f (a)) (unary emit-bignum? a))
  487. (#('flonum? #f (a)) (unary emit-flonum? a))
  488. (#('compnum? #f (a)) (unary emit-compnum? a))
  489. (#('fracnum? #f (a)) (unary emit-fracnum? a))
  490. ;; Binary predicates.
  491. (#('eq? #f (a b)) (binary-test emit-eq? a b))
  492. (#('heap-numbers-equal? #f (a b))
  493. (binary-test emit-heap-numbers-equal? a b))
  494. (#('< #f (a b)) (binary-< emit-<? a b))
  495. (#('<= #f (a b)) (binary-<= emit-<? a b))
  496. (#('= #f (a b)) (binary-test emit-=? a b))
  497. (#('u64-< #f (a b)) (binary-< emit-u64<? a b))
  498. (#('u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b))
  499. (#('imm-u64-< b (a)) (binary-</imm emit-imm-u64<? a b))
  500. (#('u64-= #f (a b)) (binary-test emit-u64=? a b))
  501. (#('u64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
  502. (#('s64-= #f (a b)) (binary-test emit-u64=? a b))
  503. (#('s64-imm-= b (a)) (binary-test/imm emit-s64-imm=? a b))
  504. (#('s64-< #f (a b)) (binary-< emit-s64<? a b))
  505. (#('s64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b))
  506. (#('imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b))
  507. (#('f64-< #f (a b)) (binary-< emit-f64<? a b))
  508. (#('f64-<= #f (a b)) (binary-<= emit-f64<? a b))
  509. (#('f64-= #f (a b)) (binary-test emit-f64=? a b))))
  510. (define (skip-elided-conts label)
  511. (if (elide-cont? label)
  512. (skip-elided-conts (1+ label))
  513. label))
  514. (define (compile-expression label k exp)
  515. (let* ((forwarded-k (forward-label k))
  516. (fallthrough? (= forwarded-k (skip-elided-conts (1+ label))))
  517. (cont (intmap-ref cps k)))
  518. (define (maybe-emit-jump)
  519. (unless fallthrough?
  520. (emit-j asm forwarded-k)))
  521. (define (compile-values nvalues)
  522. (emit-moves (lookup-send-parallel-moves label allocation))
  523. (match cont
  524. (($ $ktail)
  525. (compile-tail nvalues emit-return-values))
  526. (($ $kargs)
  527. (maybe-emit-jump))))
  528. (define (compile-call kfun proc args)
  529. (emit-moves (lookup-send-parallel-moves label allocation))
  530. (let* ((nclosure (if proc 1 0))
  531. (nargs (+ nclosure (length args))))
  532. (match cont
  533. (($ $ktail)
  534. (compile-tail nargs
  535. (if kfun
  536. (lambda (asm)
  537. (emit-tail-call-label asm kfun))
  538. emit-tail-call)))
  539. (_
  540. (let ((proc-slot (lookup-call-proc-slot label allocation)))
  541. (emit-handle-interrupts asm)
  542. (if kfun
  543. (emit-call-label asm proc-slot nargs kfun)
  544. (emit-call asm proc-slot nargs))
  545. (emit-slot-map asm proc-slot
  546. (lookup-slot-map label allocation))
  547. (compile-receive label proc-slot cont)
  548. (maybe-emit-jump))))))
  549. (match exp
  550. (($ $values args)
  551. (compile-values (length args)))
  552. (($ $call proc args)
  553. (compile-call #f proc args))
  554. (($ $callk kfun proc args)
  555. (compile-call kfun proc args))
  556. (($ $calli args callee)
  557. (error "unreachable"))
  558. (_
  559. (match cont
  560. (($ $kargs names vars)
  561. (match vars
  562. (() (compile-effect exp))
  563. ((var)
  564. (let ((dst (maybe-slot var)))
  565. (when dst
  566. (compile-value exp dst)))))
  567. (maybe-emit-jump)))))))
  568. (define (compile-term label term)
  569. (match term
  570. (($ $continue k src exp)
  571. (when src
  572. (emit-source asm src))
  573. (unless (elide-cont? label)
  574. (compile-expression label k exp)))
  575. (($ $branch kf kt src op param args)
  576. (when src
  577. (emit-source asm src))
  578. (compile-test label (skip-elided-conts (1+ label))
  579. (forward-label kf) (forward-label kt)
  580. op param args))
  581. (($ $switch kf kt* src arg)
  582. (when src
  583. (emit-source asm src))
  584. (emit-jtable asm (from-sp (slot arg))
  585. (list->vector (map forward-label
  586. (append kt* (list kf))))))
  587. (($ $prompt k kh src escape? tag)
  588. (when src
  589. (emit-source asm src))
  590. (compile-prompt label (skip-elided-conts k) kh escape? tag))
  591. (($ $throw src op param args)
  592. (when src
  593. (emit-source asm src))
  594. (compile-throw op param args))))
  595. (define (compile-cont label cont)
  596. (match cont
  597. (($ $kfun src meta self tail entry)
  598. (when src
  599. (emit-source asm src))
  600. (emit-begin-program asm label meta)
  601. (match (intmap-ref cps entry)
  602. (($ $kclause)
  603. ;; Leave arity handling to the dispatcher.
  604. #t)
  605. (($ $kargs names vars _)
  606. ;; Otherwise the $kfun continues to the $kargs directly,
  607. ;; without any arity checking, so we begin the arity here.
  608. (emit-begin-unchecked-arity asm (->bool self) names frame-size)
  609. (when self
  610. (emit-definition asm 'closure 0 'scm)))))
  611. (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alt)
  612. (let ((first? (match (intmap-ref cps (1- label))
  613. (($ $kfun) #t)
  614. (_ #f)))
  615. (has-closure? (match (intmap-ref cps (intmap-next cps))
  616. (($ $kfun src meta self tail) (->bool self))))
  617. (kw-indices (map (match-lambda
  618. ((key name sym)
  619. (cons key (lookup-slot sym allocation))))
  620. kw)))
  621. (unless first?
  622. (emit-end-arity asm))
  623. (emit-label asm label)
  624. (emit-begin-kw-arity asm has-closure? req opt rest kw-indices
  625. allow-other-keys? frame-size alt)
  626. (when has-closure?
  627. ;; Most arities define a closure binding in slot 0.
  628. (emit-definition asm 'closure 0 'scm))
  629. ;; Usually we just fall through, but it could be the body is
  630. ;; contified into another clause.
  631. (let ((body (forward-label body)))
  632. (unless (= body (skip-elided-conts (1+ label)))
  633. (emit-j asm body)))))
  634. (($ $kargs names vars term)
  635. (emit-label asm label)
  636. (for-each (lambda (name var)
  637. (let ((slot (maybe-slot var)))
  638. (when slot
  639. (let ((repr (lookup-representation var allocation)))
  640. (emit-definition asm name slot repr)))))
  641. names vars)
  642. (compile-term label term))
  643. (($ $kreceive arity kargs)
  644. (emit-label asm label))
  645. (($ $ktail)
  646. (emit-end-arity asm)
  647. (emit-end-program asm))))
  648. (intmap-for-each compile-cont cps)))
  649. (define (compile-bytecode exp env opts)
  650. (let ((asm (make-assembler)))
  651. (intmap-for-each (lambda (kfun body)
  652. (compile-function (intmap-select exp body) asm opts))
  653. (compute-reachable-functions exp 0))
  654. (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
  655. env
  656. env)))