module/language/cps/compile-bytecode.scm

   1 ;;; Continuation-passing style (CPS) intermediate language (IL)
   2
   3 ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20 ;;;
  21 ;;; Compiling CPS to bytecode.  The result is in the bytecode language,
  22 ;;; which happens to be an ELF image as a bytecode.
  23 ;;;
  24 ;;; Code:
  25
  26 (define-module (language cps compile-bytecode)
  27   #:use-module (ice-9 match)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (language cps)
  30   #:use-module (language cps arities)
  31   #:use-module (language cps closure-conversion)
  32   #:use-module (language cps contification)
  33   #:use-module (language cps constructors)
  34   #:use-module (language cps dce)
  35   #:use-module (language cps dfg)
  36   #:use-module (language cps elide-values)
  37   #:use-module (language cps primitives)
  38   #:use-module (language cps prune-top-level-scopes)
  39   #:use-module (language cps reify-primitives)
  40   #:use-module (language cps renumber)
  41   #:use-module (language cps simplify)
  42   #:use-module (language cps slot-allocation)
  43   #:use-module (language cps specialize-primcalls)
  44   #:use-module (system vm assembler)
  45   #:export (compile-bytecode))
  46
  47 ;; TODO: Local var names.
  48
  49 (define (kw-arg-ref args kw default)
  50   (match (memq kw args)
  51     ((_ val . _) val)
  52     (_ default)))
  53
  54 (define (optimize exp opts)
  55   (define (run-pass exp pass kw default)
  56     (if (kw-arg-ref opts kw default)
  57         (pass exp)
  58         exp))
  59
  60   ;; The first DCE pass is mainly to eliminate functions that aren't
  61   ;; called.  The last is mainly to eliminate rest parameters that
  62   ;; aren't used, and thus shouldn't be consed.
  63
  64   (let* ((exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
  65          (exp (run-pass exp prune-top-level-scopes #:prune-top-level-scopes? #t))
  66          (exp (run-pass exp simplify #:simplify? #t))
  67          (exp (run-pass exp contify #:contify? #t))
  68          (exp (run-pass exp inline-constructors #:inline-constructors? #t))
  69          (exp (run-pass exp specialize-primcalls #:specialize-primcalls? #t))
  70          (exp (run-pass exp elide-values #:elide-values? #t))
  71          (exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
  72          (exp (run-pass exp simplify #:simplify? #t)))
  73     ;; Passes that are needed:
  74     ;;
  75     ;;  * Abort contification: turning abort primcalls into continuation
  76     ;;    calls, and eliding prompts if possible.
  77     ;;
  78     ;;  * Common subexpression elimination.  Desperately needed.
  79     ;;
  80     ;;  * Loop peeling.  Unrolls the first round through a loop if the
  81     ;;    loop has effects that CSE can work on.  Requires effects
  82     ;;    analysis.  When run before CSE, loop peeling is the equivalent
  83     ;;    of loop-invariant code motion (LICM).
  84
  85     exp))
  86
  87 (define (collect-conts f cfa)
  88   (let ((contv (make-vector (cfa-k-count cfa) #f)))
  89     (fold-local-conts
  90      (lambda (k cont tail)
  91        (let ((idx (cfa-k-idx cfa k #:default (lambda (k) #f))))
  92          (when idx
  93            (vector-set! contv idx cont))))
  94      '()
  95      f)
  96     contv))
  97
  98 (define (compile-fun f asm)
  99   (let* ((dfg (compute-dfg f #:global? #f))
 100          (cfa (analyze-control-flow f dfg))
 101          (allocation (allocate-slots f dfg))
 102          (contv (collect-conts f cfa)))
 103     (define (lookup-cont k)
 104       (vector-ref contv (cfa-k-idx cfa k)))
 105
 106     (define (maybe-slot sym)
 107       (lookup-maybe-slot sym allocation))
 108
 109     (define (slot sym)
 110       (lookup-slot sym allocation))
 111
 112     (define (constant sym)
 113       (lookup-constant-value sym allocation))
 114
 115     (define (maybe-mov dst src)
 116       (unless (= dst src)
 117         (emit-mov asm dst src)))
 118
 119     (define (maybe-load-constant slot src)
 120       (call-with-values (lambda ()
 121                           (lookup-maybe-constant-value src allocation))
 122         (lambda (has-const? val)
 123           (and has-const?
 124                (begin
 125                  (emit-load-constant asm slot val)
 126                  #t)))))
 127
 128     (define (compile-entry meta)
 129       (match (vector-ref contv 0)
 130         (($ $kentry self tail clause)
 131          (emit-begin-program asm (cfa-k-sym cfa 0) meta)
 132          (compile-clause 1)
 133          (emit-end-program asm))))
 134
 135     (define (compile-clause n)
 136       (match (vector-ref contv n)
 137         (($ $kclause ($ $arity req opt rest kw allow-other-keys?)
 138             body alternate)
 139          (let* ((kw-indices (map (match-lambda
 140                                   ((key name sym)
 141                                    (cons key (lookup-slot sym allocation))))
 142                                  kw))
 143                 (k (cfa-k-sym cfa n))
 144                 (nlocals (lookup-nlocals k allocation)))
 145            (emit-label asm k)
 146            (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys?
 147                                 nlocals
 148                                 (match alternate (#f #f) (($ $cont alt) alt)))
 149            (let ((next (compile-body (1+ n) nlocals)))
 150              (emit-end-arity asm)
 151              (match alternate
 152                (($ $cont alt)
 153                 (unless (eq? (cfa-k-sym cfa next) alt)
 154                   (error "unexpected k" alt))
 155                 (compile-clause next))
 156                (#f
 157                 (unless (= next (vector-length contv))
 158                   (error "unexpected end of clauses")))))))))
 159
 160     (define (compile-body n nlocals)
 161       (let compile-cont ((n n))
 162         (if (= n (vector-length contv))
 163             n
 164             (match (vector-ref contv n)
 165               (($ $kclause) n)
 166               (($ $kargs _ _ term)
 167                (emit-label asm (cfa-k-sym cfa n))
 168                (let find-exp ((term term))
 169                  (match term
 170                    (($ $letk conts term)
 171                     (find-exp term))
 172                    (($ $continue k src exp)
 173                     (when src
 174                       (emit-source asm src))
 175                     (compile-expression n k exp nlocals)
 176                     (compile-cont (1+ n))))))
 177               (_
 178                (emit-label asm (cfa-k-sym cfa n))
 179                (compile-cont (1+ n)))))))
 180
 181     (define (compile-expression n k exp nlocals)
 182       (let* ((label (cfa-k-sym cfa n))
 183              (k-idx (cfa-k-idx cfa k))
 184              (fallthrough? (= k-idx (1+ n))))
 185         (define (maybe-emit-jump)
 186           (unless (= k-idx (1+ n))
 187             (emit-br asm k)))
 188         (match (vector-ref contv k-idx)
 189           (($ $ktail)
 190            (compile-tail label exp))
 191           (($ $kargs (name) (sym))
 192            (let ((dst (maybe-slot sym)))
 193              (when dst
 194                (compile-value label exp dst nlocals)))
 195            (maybe-emit-jump))
 196           (($ $kargs () ())
 197            (compile-effect label exp k nlocals)
 198            (maybe-emit-jump))
 199           (($ $kargs names syms)
 200            (compile-values label exp syms)
 201            (maybe-emit-jump))
 202           (($ $kif kt kf)
 203            (compile-test label exp kt kf
 204                          (and (= k-idx (1+ n))
 205                               (< (+ n 2) (cfa-k-count cfa))
 206                               (cfa-k-sym cfa (+ n 2)))))
 207           (($ $kreceive ($ $arity req () rest () #f) kargs)
 208            (compile-trunc label k exp (length req)
 209                           (and rest
 210                                (match (vector-ref contv (cfa-k-idx cfa kargs))
 211                                  (($ $kargs names (_ ... rest)) rest)))
 212                           nlocals)
 213            (unless (and (= k-idx (1+ n))
 214                         (< (+ n 2) (cfa-k-count cfa))
 215                         (eq? (cfa-k-sym cfa (+ n 2)) kargs))
 216              (emit-br asm kargs))))))
 217
 218     (define (compile-tail label exp)
 219       ;; There are only three kinds of expressions in tail position:
 220       ;; tail calls, multiple-value returns, and single-value returns.
 221       (match exp
 222         (($ $call proc args)
 223          (for-each (match-lambda
 224                     ((src . dst) (emit-mov asm dst src)))
 225                    (lookup-parallel-moves label allocation))
 226          (let ((tail-slots (cdr (iota (1+ (length args))))))
 227            (for-each maybe-load-constant tail-slots args))
 228          (emit-tail-call asm (1+ (length args))))
 229         (($ $callk k proc args)
 230          (for-each (match-lambda
 231                     ((src . dst) (emit-mov asm dst src)))
 232                    (lookup-parallel-moves label allocation))
 233          (let ((tail-slots (cdr (iota (1+ (length args))))))
 234            (for-each maybe-load-constant tail-slots args))
 235          (emit-tail-call-label asm (1+ (length args)) k))
 236         (($ $values ())
 237          (emit-reset-frame asm 1)
 238          (emit-return-values asm))
 239         (($ $values (arg))
 240          (if (maybe-slot arg)
 241              (emit-return asm (slot arg))
 242              (begin
 243                (emit-load-constant asm 1 (constant arg))
 244                (emit-return asm 1))))
 245         (($ $values args)
 246          (for-each (match-lambda
 247                     ((src . dst) (emit-mov asm dst src)))
 248                    (lookup-parallel-moves label allocation))
 249          (let ((tail-slots (cdr (iota (1+ (length args))))))
 250            (for-each maybe-load-constant tail-slots args))
 251          (emit-reset-frame asm (1+ (length args)))
 252          (emit-return-values asm))
 253         (($ $primcall 'return (arg))
 254          (emit-return asm (slot arg)))))
 255
 256     (define (compile-value label exp dst nlocals)
 257       (match exp
 258         (($ $values (arg))
 259          (or (maybe-load-constant dst arg)
 260              (maybe-mov dst (slot arg))))
 261         (($ $void)
 262          (emit-load-constant asm dst *unspecified*))
 263         (($ $const exp)
 264          (emit-load-constant asm dst exp))
 265         (($ $fun src meta () ($ $cont k))
 266          (emit-load-static-procedure asm dst k))
 267         (($ $fun src meta free ($ $cont k))
 268          (emit-make-closure asm dst k (length free)))
 269         (($ $primcall 'current-module)
 270          (emit-current-module asm dst))
 271         (($ $primcall 'cached-toplevel-box (scope name bound?))
 272          (emit-cached-toplevel-box asm dst (constant scope) (constant name)
 273                                    (constant bound?)))
 274         (($ $primcall 'cached-module-box (mod name public? bound?))
 275          (emit-cached-module-box asm dst (constant mod) (constant name)
 276                                  (constant public?) (constant bound?)))
 277         (($ $primcall 'resolve (name bound?))
 278          (emit-resolve asm dst (constant bound?) (slot name)))
 279         (($ $primcall 'free-ref (closure idx))
 280          (emit-free-ref asm dst (slot closure) (constant idx)))
 281         (($ $primcall 'vector-ref (vector index))
 282          (emit-vector-ref asm dst (slot vector) (slot index)))
 283         (($ $primcall 'make-vector/immediate (length init))
 284          (emit-make-vector/immediate asm dst (constant length) (slot init)))
 285         (($ $primcall 'vector-ref/immediate (vector index))
 286          (emit-vector-ref/immediate asm dst (slot vector) (constant index)))
 287         (($ $primcall 'allocate-struct/immediate (vtable nfields))
 288          (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields)))
 289         (($ $primcall 'struct-ref/immediate (struct n))
 290          (emit-struct-ref/immediate asm dst (slot struct) (constant n)))
 291         (($ $primcall 'builtin-ref (name))
 292          (emit-builtin-ref asm dst (constant name)))
 293         (($ $primcall 'bv-u8-ref (bv idx))
 294          (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
 295         (($ $primcall 'bv-s8-ref (bv idx))
 296          (emit-bv-s8-ref asm dst (slot bv) (slot idx)))
 297         (($ $primcall 'bv-u16-ref (bv idx))
 298          (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
 299         (($ $primcall 'bv-s16-ref (bv idx))
 300          (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
 301         (($ $primcall 'bv-u32-ref (bv idx val))
 302          (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
 303         (($ $primcall 'bv-s32-ref (bv idx val))
 304          (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
 305         (($ $primcall 'bv-u64-ref (bv idx val))
 306          (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
 307         (($ $primcall 'bv-s64-ref (bv idx val))
 308          (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
 309         (($ $primcall 'bv-f32-ref (bv idx val))
 310          (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
 311         (($ $primcall 'bv-f64-ref (bv idx val))
 312          (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
 313         (($ $primcall name args)
 314          ;; FIXME: Inline all the cases.
 315          (let ((inst (prim-instruction name)))
 316            (emit-text asm `((,inst ,dst ,@(map slot args))))))))
 317
 318     (define (compile-effect label exp k nlocals)
 319       (match exp
 320         (($ $values ()) #f)
 321         (($ $prompt escape? tag handler)
 322          (match (lookup-cont handler)
 323            (($ $kreceive ($ $arity req () rest () #f) khandler-body)
 324             (let ((receive-args (gensym "handler"))
 325                   (nreq (length req))
 326                   (proc-slot (lookup-call-proc-slot handler allocation)))
 327               (emit-prompt asm (slot tag) escape? proc-slot receive-args)
 328               (emit-br asm k)
 329               (emit-label asm receive-args)
 330               (unless (and rest (zero? nreq))
 331                 (emit-receive-values asm proc-slot (->bool rest) nreq))
 332               (when (and rest
 333                          (match (vector-ref contv (cfa-k-idx cfa khandler-body))
 334                            (($ $kargs names (_ ... rest))
 335                             (maybe-slot rest))))
 336                 (emit-bind-rest asm (+ proc-slot 1 nreq)))
 337               (for-each (match-lambda
 338                          ((src . dst) (emit-mov asm dst src)))
 339                         (lookup-parallel-moves handler allocation))
 340               (emit-reset-frame asm nlocals)
 341               (emit-br asm khandler-body)))))
 342         (($ $primcall 'cache-current-module! (sym scope))
 343          (emit-cache-current-module! asm (slot sym) (constant scope)))
 344         (($ $primcall 'free-set! (closure idx value))
 345          (emit-free-set! asm (slot closure) (slot value) (constant idx)))
 346         (($ $primcall 'box-set! (box value))
 347          (emit-box-set! asm (slot box) (slot value)))
 348         (($ $primcall 'struct-set!/immediate (struct index value))
 349          (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value)))
 350         (($ $primcall 'vector-set! (vector index value))
 351          (emit-vector-set! asm (slot vector) (slot index) (slot value)))
 352         (($ $primcall 'vector-set!/immediate (vector index value))
 353          (emit-vector-set!/immediate asm (slot vector) (constant index)
 354                                      (slot value)))
 355         (($ $primcall 'variable-set! (var val))
 356          (emit-box-set! asm (slot var) (slot val)))
 357         (($ $primcall 'set-car! (pair value))
 358          (emit-set-car! asm (slot pair) (slot value)))
 359         (($ $primcall 'set-cdr! (pair value))
 360          (emit-set-cdr! asm (slot pair) (slot value)))
 361         (($ $primcall 'define! (sym value))
 362          (emit-define! asm (slot sym) (slot value)))
 363         (($ $primcall 'push-fluid (fluid val))
 364          (emit-push-fluid asm (slot fluid) (slot val)))
 365         (($ $primcall 'pop-fluid ())
 366          (emit-pop-fluid asm))
 367         (($ $primcall 'wind (winder unwinder))
 368          (emit-wind asm (slot winder) (slot unwinder)))
 369         (($ $primcall 'bv-u8-set! (bv idx val))
 370          (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
 371         (($ $primcall 'bv-s8-set! (bv idx val))
 372          (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
 373         (($ $primcall 'bv-u16-set! (bv idx val))
 374          (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
 375         (($ $primcall 'bv-s16-set! (bv idx val))
 376          (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
 377         (($ $primcall 'bv-u32-set! (bv idx val))
 378          (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
 379         (($ $primcall 'bv-s32-set! (bv idx val))
 380          (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
 381         (($ $primcall 'bv-u64-set! (bv idx val))
 382          (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
 383         (($ $primcall 'bv-s64-set! (bv idx val))
 384          (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
 385         (($ $primcall 'bv-f32-set! (bv idx val))
 386          (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
 387         (($ $primcall 'bv-f64-set! (bv idx val))
 388          (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
 389         (($ $primcall 'unwind ())
 390          (emit-unwind asm))))
 391
 392     (define (compile-values label exp syms)
 393       (match exp
 394         (($ $values args)
 395          (for-each (match-lambda
 396                     ((src . dst) (emit-mov asm dst src)))
 397                    (lookup-parallel-moves label allocation))
 398          (for-each maybe-load-constant (map slot syms) args))))
 399
 400     (define (compile-test label exp kt kf next-label)
 401       (define (unary op sym)
 402         (cond
 403          ((eq? kt next-label)
 404           (op asm (slot sym) #t kf))
 405          (else
 406           (op asm (slot sym) #f kt)
 407           (unless (eq? kf next-label)
 408             (emit-br asm kf)))))
 409       (define (binary op a b)
 410         (cond
 411          ((eq? kt next-label)
 412           (op asm (slot a) (slot b) #t kf))
 413          (else
 414           (op asm (slot a) (slot b) #f kt)
 415           (unless (eq? kf next-label)
 416             (emit-br asm kf)))))
 417       (match exp
 418         (($ $values (sym))
 419          (call-with-values (lambda ()
 420                              (lookup-maybe-constant-value sym allocation))
 421            (lambda (has-const? val)
 422              (if has-const?
 423                  (if val
 424                      (unless (eq? kt next-label)
 425                        (emit-br asm kt))
 426                      (unless (eq? kf next-label)
 427                        (emit-br asm kf)))
 428                  (unary emit-br-if-true sym)))))
 429         (($ $primcall 'null? (a)) (unary emit-br-if-null a))
 430         (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
 431         (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
 432         (($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
 433         (($ $primcall 'char? (a)) (unary emit-br-if-char a))
 434         (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
 435         (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
 436         (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
 437         (($ $primcall 'string? (a)) (unary emit-br-if-string a))
 438         (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a))
 439         ;; Add more TC7 tests here.  Keep in sync with
 440         ;; *branching-primcall-arities* in (language cps primitives) and
 441         ;; the set of macro-instructions in assembly.scm.
 442         (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
 443         (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
 444         (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
 445         (($ $primcall '< (a b)) (binary emit-br-if-< a b))
 446         (($ $primcall '<= (a b)) (binary emit-br-if-<= a b))
 447         (($ $primcall '= (a b)) (binary emit-br-if-= a b))
 448         (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
 449         (($ $primcall '> (a b)) (binary emit-br-if-< b a))))
 450
 451     (define (compile-trunc label k exp nreq rest-var nlocals)
 452       (define (do-call proc args emit-call)
 453         (let* ((proc-slot (lookup-call-proc-slot label allocation))
 454                (nargs (1+ (length args)))
 455                (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
 456           (for-each (match-lambda
 457                      ((src . dst) (emit-mov asm dst src)))
 458                     (lookup-parallel-moves label allocation))
 459           (for-each maybe-load-constant arg-slots (cons proc args))
 460           (emit-call asm proc-slot nargs)
 461           (emit-dead-slot-map asm proc-slot
 462                               (lookup-dead-slot-map label allocation))
 463           (cond
 464            ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
 465                  (match (lookup-parallel-moves k allocation)
 466                    ((((? (lambda (src) (= src (1+ proc-slot))) src)
 467                       . dst)) dst)
 468                    (_ #f)))
 469             ;; The usual case: one required live return value, ignoring
 470             ;; any additional values.
 471             => (lambda (dst)
 472                  (emit-receive asm dst proc-slot nlocals)))
 473            (else
 474             (unless (and (zero? nreq) rest-var)
 475               (emit-receive-values asm proc-slot (->bool rest-var) nreq))
 476             (when (and rest-var (maybe-slot rest-var))
 477               (emit-bind-rest asm (+ proc-slot 1 nreq)))
 478             (for-each (match-lambda
 479                        ((src . dst) (emit-mov asm dst src)))
 480                       (lookup-parallel-moves k allocation))
 481             (emit-reset-frame asm nlocals)))))
 482       (match exp
 483         (($ $call proc args)
 484          (do-call proc args
 485                   (lambda (asm proc-slot nargs)
 486                     (emit-call asm proc-slot nargs))))
 487         (($ $callk k proc args)
 488          (do-call proc args
 489                   (lambda (asm proc-slot nargs)
 490                     (emit-call-label asm proc-slot nargs k))))))
 491
 492     (match f
 493       (($ $fun src meta free ($ $cont k ($ $kentry self tail clause)))
 494        ;; FIXME: src on kentry instead?
 495        (when src
 496          (emit-source asm src))
 497        (compile-entry (or meta '()))))))
 498
 499 (define (visit-funs proc exp)
 500   (match exp
 501     (($ $continue _ _ exp)
 502      (visit-funs proc exp))
 503
 504     (($ $fun src meta free body)
 505      (proc exp)
 506      (visit-funs proc body))
 507
 508     (($ $letk conts body)
 509      (visit-funs proc body)
 510      (for-each (lambda (cont) (visit-funs proc cont)) conts))
 511
 512     (($ $cont sym ($ $kargs names syms body))
 513      (visit-funs proc body))
 514
 515     (($ $cont sym ($ $kclause arity body alternate))
 516      (visit-funs proc body)
 517      (when alternate
 518        (visit-funs proc alternate)))
 519
 520     (($ $cont sym ($ $kentry self tail clause))
 521      (when clause
 522        (visit-funs proc clause)))
 523
 524     (_ (values))))
 525
 526 (define (compile-bytecode exp env opts)
 527   (let* ((exp (fix-arities exp))
 528          (exp (optimize exp opts))
 529          (exp (convert-closures exp))
 530          (exp (reify-primitives exp))
 531          (exp (renumber exp))
 532          (asm (make-assembler)))
 533     (visit-funs (lambda (fun)
 534                   (compile-fun fun asm))
 535                 exp)
 536     (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
 537             env
 538             env)))