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