module/language/tree-il/compile-glil.scm

   1 ;;; TREE-IL -> GLIL compiler
   2
   3 ;; Copyright (C) 2001,2008,2009 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 ;;; Code:
  20
  21 (define-module (language tree-il compile-glil)
  22   #:use-module (system base syntax)
  23   #:use-module (system base pmatch)
  24   #:use-module (system base message)
  25   #:use-module (ice-9 receive)
  26   #:use-module (language glil)
  27   #:use-module (system vm instruction)
  28   #:use-module (language tree-il)
  29   #:use-module (language tree-il optimize)
  30   #:use-module (language tree-il analyze)
  31   #:export (compile-glil))
  32
  33 ;;; TODO:
  34 ;;
  35 ;; call-with-values -> mv-bind
  36 ;; basic degenerate-case reduction
  37
  38 ;; allocation:
  39 ;;  sym -> {lambda -> address}
  40 ;;  lambda -> (nlocs . closure-vars)
  41 ;;
  42 ;; address := (local? boxed? . index)
  43 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
  44 ;; free variable addresses are relative to parent proc.
  45
  46 (define *comp-module* (make-fluid))
  47
  48 (define %warning-passes
  49   `((unused-variable . ,report-unused-variables)))
  50
  51 (define (compile-glil x e opts)
  52   (define warnings
  53     (or (and=> (memq #:warnings opts) cadr)
  54         '()))
  55
  56   (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
  57          (x (optimize! x e opts))
  58          (allocation (analyze-lexicals x)))
  59
  60     ;; Go throught the warning passes.
  61     (for-each (lambda (kind)
  62                 (let ((warn (assoc-ref %warning-passes kind)))
  63                   (and (procedure? warn)
  64                        (warn x))))
  65               warnings)
  66
  67     (with-fluid* *comp-module* (or (and e (car e)) (current-module))
  68       (lambda ()
  69         (values (flatten-lambda x allocation)
  70                 (and e (cons (car e) (cddr e)))
  71                 e)))))
  72
  73 \f
  74
  75 (define *primcall-ops* (make-hash-table))
  76 (for-each
  77  (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
  78  '(((eq? . 2) . eq?)
  79    ((eqv? . 2) . eqv?)
  80    ((equal? . 2) . equal?)
  81    ((= . 2) . ee?)
  82    ((< . 2) . lt?)
  83    ((> . 2) . gt?)
  84    ((<= . 2) . le?)
  85    ((>= . 2) . ge?)
  86    ((+ . 2) . add)
  87    ((- . 2) . sub)
  88    ((1+ . 1) . add1)
  89    ((1- . 1) . sub1)
  90    ((* . 2) . mul)
  91    ((/ . 2) . div)
  92    ((quotient . 2) . quo)
  93    ((remainder . 2) . rem)
  94    ((modulo . 2) . mod)
  95    ((not . 1) . not)
  96    ((pair? . 1) . pair?)
  97    ((cons . 2) . cons)
  98    ((car . 1) . car)
  99    ((cdr . 1) . cdr)
 100    ((set-car! . 2) . set-car!)
 101    ((set-cdr! . 2) . set-cdr!)
 102    ((null? . 1) . null?)
 103    ((list? . 1) . list?)
 104    (list . list)
 105    (vector . vector)
 106    ((@slot-ref . 2) . slot-ref)
 107    ((@slot-set! . 3) . slot-set)
 108    ((vector-ref . 2) . vector-ref)
 109    ((vector-set! . 3) . vector-set)
 110
 111    ((bytevector-u8-ref . 2) . bv-u8-ref)
 112    ((bytevector-u8-set! . 3) . bv-u8-set)
 113    ((bytevector-s8-ref . 2) . bv-s8-ref)
 114    ((bytevector-s8-set! . 3) . bv-s8-set)
 115
 116    ((bytevector-u16-ref . 3) . bv-u16-ref)
 117    ((bytevector-u16-set! . 4) . bv-u16-set)
 118    ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
 119    ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
 120    ((bytevector-s16-ref . 3) . bv-s16-ref)
 121    ((bytevector-s16-set! . 4) . bv-s16-set)
 122    ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
 123    ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
 124
 125    ((bytevector-u32-ref . 3) . bv-u32-ref)
 126    ((bytevector-u32-set! . 4) . bv-u32-set)
 127    ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
 128    ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
 129    ((bytevector-s32-ref . 3) . bv-s32-ref)
 130    ((bytevector-s32-set! . 4) . bv-s32-set)
 131    ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
 132    ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
 133
 134    ((bytevector-u64-ref . 3) . bv-u64-ref)
 135    ((bytevector-u64-set! . 4) . bv-u64-set)
 136    ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
 137    ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
 138    ((bytevector-s64-ref . 3) . bv-s64-ref)
 139    ((bytevector-s64-set! . 4) . bv-s64-set)
 140    ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
 141    ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
 142
 143    ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
 144    ((bytevector-ieee-single-set! . 4) . bv-f32-set)
 145    ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
 146    ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
 147    ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
 148    ((bytevector-ieee-double-set! . 4) . bv-f64-set)
 149    ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
 150    ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
 151
 152
 153 \f
 154
 155 (define (make-label) (gensym ":L"))
 156
 157 (define (vars->bind-list ids vars allocation proc)
 158   (map (lambda (id v)
 159          (pmatch (hashq-ref (hashq-ref allocation v) proc)
 160            ((#t ,boxed? . ,n)
 161             (list id boxed? n))
 162            (,x (error "badness" x))))
 163        ids
 164        vars))
 165
 166 (define (emit-bindings src ids vars allocation proc emit-code)
 167   (if (pair? vars)
 168       (emit-code src (make-glil-bind
 169                       (vars->bind-list ids vars allocation proc)))))
 170
 171 (define (with-output-to-code proc)
 172   (let ((out '()))
 173     (define (emit-code src x)
 174       (set! out (cons x out))
 175       (if src
 176           (set! out (cons (make-glil-source src) out))))
 177     (proc emit-code)
 178     (reverse out)))
 179
 180 (define (flatten-lambda x allocation)
 181   (receive (ids vars nargs nrest)
 182       (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
 183                (oids '()) (ovars '()) (n 0))
 184           (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
 185                 ((pair? vars) (lp (cdr ids) (cdr vars)
 186                                   (cons (car ids) oids) (cons (car vars) ovars)
 187                                   (1+ n)))
 188                 (else (values (reverse (cons ids oids))
 189                               (reverse (cons vars ovars))
 190                               (1+ n) 1))))
 191     (let ((nlocs (car (hashq-ref allocation x))))
 192       (make-glil-program
 193        nargs nrest nlocs (lambda-meta x)
 194        (with-output-to-code
 195         (lambda (emit-code)
 196           ;; write bindings and source debugging info
 197           (emit-bindings #f ids vars allocation x emit-code)
 198           (if (lambda-src x)
 199               (emit-code #f (make-glil-source (lambda-src x))))
 200           ;; box args if necessary
 201           (for-each
 202            (lambda (v)
 203              (pmatch (hashq-ref (hashq-ref allocation v) x)
 204                ((#t #t . ,n)
 205                 (emit-code #f (make-glil-lexical #t #f 'ref n))
 206                 (emit-code #f (make-glil-lexical #t #t 'box n)))))
 207            vars)
 208           ;; and here, here, dear reader: we compile.
 209           (flatten (lambda-body x) allocation x emit-code)))))))
 210
 211 (define (flatten x allocation proc emit-code)
 212   (define (emit-label label)
 213     (emit-code #f (make-glil-label label)))
 214   (define (emit-branch src inst label)
 215     (emit-code src (make-glil-branch inst label)))
 216
 217   ;; LMVRA == "let-values MV return address"
 218   (let comp ((x x) (context 'tail) (LMVRA #f))
 219     (define (comp-tail tree) (comp tree context LMVRA))
 220     (define (comp-push tree) (comp tree 'push #f))
 221     (define (comp-drop tree) (comp tree 'drop #f))
 222     (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA))
 223
 224     (record-case x
 225       ((<void>)
 226        (case context
 227          ((push vals) (emit-code #f (make-glil-void)))
 228          ((tail)
 229           (emit-code #f (make-glil-void))
 230           (emit-code #f (make-glil-call 'return 1)))))
 231
 232       ((<const> src exp)
 233        (case context
 234          ((push vals) (emit-code src (make-glil-const exp)))
 235          ((tail)
 236           (emit-code src (make-glil-const exp))
 237           (emit-code #f (make-glil-call 'return 1)))))
 238
 239       ;; FIXME: should represent sequence as exps tail
 240       ((<sequence> src exps)
 241        (let lp ((exps exps))
 242          (if (null? (cdr exps))
 243              (comp-tail (car exps))
 244              (begin
 245                (comp-drop (car exps))
 246                (lp (cdr exps))))))
 247
 248       ((<application> src proc args)
 249        ;; FIXME: need a better pattern-matcher here
 250        (cond
 251         ((and (primitive-ref? proc)
 252               (eq? (primitive-ref-name proc) '@apply)
 253               (>= (length args) 1))
 254          (let ((proc (car args))
 255                (args (cdr args)))
 256            (cond
 257             ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 258                   (not (eq? context 'push)) (not (eq? context 'vals)))
 259              ;; tail: (lambda () (apply values '(1 2)))
 260              ;; drop: (lambda () (apply values '(1 2)) 3)
 261              ;; push: (lambda () (list (apply values '(10 12)) 1))
 262              (case context
 263                ((drop) (for-each comp-drop args))
 264                ((tail)
 265                 (for-each comp-push args)
 266                 (emit-code src (make-glil-call 'return/values* (length args))))))
 267
 268             (else
 269              (case context
 270                ((tail)
 271                 (comp-push proc)
 272                 (for-each comp-push args)
 273                 (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
 274                ((push)
 275                 (comp-push proc)
 276                 (for-each comp-push args)
 277                 (emit-code src (make-glil-call 'apply (1+ (length args)))))
 278                ((vals)
 279                 (comp-vals
 280                  (make-application src (make-primitive-ref #f 'apply)
 281                                    (cons proc args))
 282                  LMVRA))
 283                ((drop)
 284                 ;; Well, shit. The proc might return any number of
 285                 ;; values (including 0), since it's in a drop context,
 286                 ;; yet apply does not create a MV continuation. So we
 287                 ;; mv-call out to our trampoline instead.
 288                 (comp-drop
 289                  (make-application src (make-primitive-ref #f 'apply)
 290                                    (cons proc args)))))))))
 291
 292         ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 293               (not (eq? context 'push)))
 294          ;; tail: (lambda () (values '(1 2)))
 295          ;; drop: (lambda () (values '(1 2)) 3)
 296          ;; push: (lambda () (list (values '(10 12)) 1))
 297          ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
 298          (case context
 299            ((drop) (for-each comp-drop args))
 300            ((vals)
 301             (for-each comp-push args)
 302             (emit-code #f (make-glil-const (length args)))
 303             (emit-branch src 'br LMVRA))
 304            ((tail)
 305             (for-each comp-push args)
 306             (emit-code src (make-glil-call 'return/values (length args))))))
 307
 308         ((and (primitive-ref? proc)
 309               (eq? (primitive-ref-name proc) '@call-with-values)
 310               (= (length args) 2))
 311          ;; CONSUMER
 312          ;; PRODUCER
 313          ;; (mv-call MV)
 314          ;; ([tail]-call 1)
 315          ;; goto POST
 316          ;; MV: [tail-]call/nargs
 317          ;; POST: (maybe-drop)
 318          (case context
 319            ((vals)
 320             ;; Fall back.
 321             (comp-vals
 322              (make-application src (make-primitive-ref #f 'call-with-values)
 323                                args)
 324              LMVRA))
 325            (else
 326             (let ((MV (make-label)) (POST (make-label))
 327                   (producer (car args)) (consumer (cadr args)))
 328               (comp-push consumer)
 329               (comp-push producer)
 330               (emit-code src (make-glil-mv-call 0 MV))
 331               (case context
 332                 ((tail) (emit-code src (make-glil-call 'goto/args 1)))
 333                 (else   (emit-code src (make-glil-call 'call 1))
 334                         (emit-branch #f 'br POST)))
 335               (emit-label MV)
 336               (case context
 337                 ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
 338                 (else   (emit-code src (make-glil-call 'call/nargs 0))
 339                         (emit-label POST)
 340                         (if (eq? context 'drop)
 341                             (emit-code #f (make-glil-call 'drop 1)))))))))
 342
 343         ((and (primitive-ref? proc)
 344               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
 345               (= (length args) 1))
 346          (case context
 347            ((tail)
 348             (comp-push (car args))
 349             (emit-code src (make-glil-call 'goto/cc 1)))
 350            ((vals)
 351             (comp-vals
 352              (make-application
 353               src (make-primitive-ref #f 'call-with-current-continuation)
 354               args)
 355              LMVRA))
 356            ((push)
 357             (comp-push (car args))
 358             (emit-code src (make-glil-call 'call/cc 1)))
 359            ((drop)
 360             ;; Crap. Just like `apply' in drop context.
 361             (comp-drop
 362              (make-application
 363               src (make-primitive-ref #f 'call-with-current-continuation)
 364               args)))))
 365
 366         ((and (primitive-ref? proc)
 367               (or (hash-ref *primcall-ops*
 368                             (cons (primitive-ref-name proc) (length args)))
 369                   (hash-ref *primcall-ops* (primitive-ref-name proc))))
 370          => (lambda (op)
 371               (for-each comp-push args)
 372               (emit-code src (make-glil-call op (length args)))
 373               (case (instruction-pushes op)
 374                 ((0)
 375                  (case context
 376                    ((tail) (emit-code #f (make-glil-void))
 377                            (emit-code #f (make-glil-call 'return 1)))
 378                    ((push vals) (emit-code #f (make-glil-void)))))
 379                 ((1)
 380                  (case context
 381                    ((tail) (emit-code #f (make-glil-call 'return 1)))
 382                    ((drop) (emit-code #f (make-glil-call 'drop 1)))))
 383                 (else
 384                  (error "bad primitive op: too many pushes"
 385                         op (instruction-pushes op))))))
 386
 387         (else
 388          (comp-push proc)
 389          (for-each comp-push args)
 390          (let ((len (length args)))
 391            (case context
 392              ((tail) (emit-code src (make-glil-call 'goto/args len)))
 393              ((push) (emit-code src (make-glil-call 'call len)))
 394              ((vals) (emit-code src (make-glil-call 'mv-call len LMVRA)))
 395              ((drop)
 396               (let ((MV (make-label)) (POST (make-label)))
 397                 (emit-code src (make-glil-mv-call len MV))
 398                 (emit-code #f (make-glil-call 'drop 1))
 399                 (emit-branch #f 'br POST)
 400                 (emit-label MV)
 401                 (emit-code #f (make-glil-mv-bind '() #f))
 402                 (emit-code #f (make-glil-unbind))
 403                 (emit-label POST))))))))
 404
 405       ((<conditional> src test then else)
 406        ;;     TEST
 407        ;;     (br-if-not L1)
 408        ;;     THEN
 409        ;;     (br L2)
 410        ;; L1: ELSE
 411        ;; L2:
 412        (let ((L1 (make-label)) (L2 (make-label)))
 413          (comp-push test)
 414          (emit-branch src 'br-if-not L1)
 415          (comp-tail then)
 416          (if (not (eq? context 'tail))
 417              (emit-branch #f 'br L2))
 418          (emit-label L1)
 419          (comp-tail else)
 420          (if (not (eq? context 'tail))
 421              (emit-label L2))))
 422
 423       ((<primitive-ref> src name)
 424        (cond
 425         ((eq? (module-variable (fluid-ref *comp-module*) name)
 426               (module-variable the-root-module name))
 427          (case context
 428            ((push vals)
 429             (emit-code src (make-glil-toplevel 'ref name)))
 430            ((tail)
 431             (emit-code src (make-glil-toplevel 'ref name))
 432             (emit-code #f (make-glil-call 'return 1)))))
 433         (else
 434          (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
 435          (case context
 436            ((push vals)
 437             (emit-code src (make-glil-module 'ref '(guile) name #f)))
 438            ((tail)
 439             (emit-code src (make-glil-module 'ref '(guile) name #f))
 440             (emit-code #f (make-glil-call 'return 1)))))))
 441
 442       ((<lexical-ref> src name gensym)
 443        (case context
 444          ((push vals tail)
 445           (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
 446             ((,local? ,boxed? . ,index)
 447              (emit-code src (make-glil-lexical local? boxed? 'ref index)))
 448             (,loc
 449              (error "badness" x loc)))))
 450        (case context
 451          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 452
 453       ((<lexical-set> src name gensym exp)
 454        (comp-push exp)
 455        (pmatch (hashq-ref (hashq-ref allocation gensym) proc)
 456          ((,local? ,boxed? . ,index)
 457           (emit-code src (make-glil-lexical local? boxed? 'set index)))
 458          (,loc
 459           (error "badness" x loc)))
 460        (case context
 461          ((push vals)
 462           (emit-code #f (make-glil-void)))
 463          ((tail)
 464           (emit-code #f (make-glil-void))
 465           (emit-code #f (make-glil-call 'return 1)))))
 466
 467       ((<module-ref> src mod name public?)
 468        (emit-code src (make-glil-module 'ref mod name public?))
 469        (case context
 470          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 471          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 472
 473       ((<module-set> src mod name public? exp)
 474        (comp-push exp)
 475        (emit-code src (make-glil-module 'set mod name public?))
 476        (case context
 477          ((push vals)
 478           (emit-code #f (make-glil-void)))
 479          ((tail)
 480           (emit-code #f (make-glil-void))
 481           (emit-code #f (make-glil-call 'return 1)))))
 482
 483       ((<toplevel-ref> src name)
 484        (emit-code src (make-glil-toplevel 'ref name))
 485        (case context
 486          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 487          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 488
 489       ((<toplevel-set> src name exp)
 490        (comp-push exp)
 491        (emit-code src (make-glil-toplevel 'set name))
 492        (case context
 493          ((push vals)
 494           (emit-code #f (make-glil-void)))
 495          ((tail)
 496           (emit-code #f (make-glil-void))
 497           (emit-code #f (make-glil-call 'return 1)))))
 498
 499       ((<toplevel-define> src name exp)
 500        (comp-push exp)
 501        (emit-code src (make-glil-toplevel 'define name))
 502        (case context
 503          ((push vals)
 504           (emit-code #f (make-glil-void)))
 505          ((tail)
 506           (emit-code #f (make-glil-void))
 507           (emit-code #f (make-glil-call 'return 1)))))
 508
 509       ((<lambda>)
 510        (let ((free-locs (cdr (hashq-ref allocation x))))
 511          (case context
 512            ((push vals tail)
 513             (emit-code #f (flatten-lambda x allocation))
 514             (if (not (null? free-locs))
 515                 (begin
 516                   (for-each
 517                    (lambda (loc)
 518                      (pmatch loc
 519                        ((,local? ,boxed? . ,n)
 520                         (emit-code #f (make-glil-lexical local? #f 'ref n)))
 521                        (else (error "what" x loc))))
 522                    free-locs)
 523                   (emit-code #f (make-glil-call 'vector (length free-locs)))
 524                   (emit-code #f (make-glil-call 'make-closure 2))))
 525             (if (eq? context 'tail)
 526                 (emit-code #f (make-glil-call 'return 1)))))))
 527
 528       ((<let> src names vars vals body)
 529        (for-each comp-push vals)
 530        (emit-bindings src names vars allocation proc emit-code)
 531        (for-each (lambda (v)
 532                    (pmatch (hashq-ref (hashq-ref allocation v) proc)
 533                      ((#t #f . ,n)
 534                       (emit-code src (make-glil-lexical #t #f 'set n)))
 535                      ((#t #t . ,n)
 536                       (emit-code src (make-glil-lexical #t #t 'box n)))
 537                      (,loc (error "badness" x loc))))
 538                  (reverse vars))
 539        (comp-tail body)
 540        (emit-code #f (make-glil-unbind)))
 541
 542       ((<letrec> src names vars vals body)
 543        (for-each (lambda (v)
 544                    (pmatch (hashq-ref (hashq-ref allocation v) proc)
 545                      ((#t #t . ,n)
 546                       (emit-code src (make-glil-lexical #t #t 'empty-box n)))
 547                      (,loc (error "badness" x loc))))
 548                  vars)
 549        (for-each comp-push vals)
 550        (emit-bindings src names vars allocation proc emit-code)
 551        (for-each (lambda (v)
 552                    (pmatch (hashq-ref (hashq-ref allocation v) proc)
 553                      ((#t #t . ,n)
 554                       (emit-code src (make-glil-lexical #t #t 'set n)))
 555                      (,loc (error "badness" x loc))))
 556                  (reverse vars))
 557        (comp-tail body)
 558        (emit-code #f (make-glil-unbind)))
 559
 560       ((<let-values> src names vars exp body)
 561        (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
 562          (cond
 563           ((pair? inames)
 564            (lp (cons (car inames) names) (cons (car ivars) vars)
 565                (cdr inames) (cdr ivars) #f))
 566           ((not (null? inames))
 567            (lp (cons inames names) (cons ivars vars) '() '() #t))
 568           (else
 569            (let ((names (reverse! names))
 570                  (vars (reverse! vars))
 571                  (MV (make-label)))
 572              (comp-vals exp MV)
 573              (emit-code #f (make-glil-const 1))
 574              (emit-label MV)
 575              (emit-code src (make-glil-mv-bind
 576                              (vars->bind-list names vars allocation proc)
 577                              rest?))
 578              (for-each (lambda (v)
 579                          (pmatch (hashq-ref (hashq-ref allocation v) proc)
 580                            ((#t #f . ,n)
 581                             (emit-code src (make-glil-lexical #t #f 'set n)))
 582                            ((#t #t . ,n)
 583                             (emit-code src (make-glil-lexical #t #t 'box n)))
 584                            (,loc (error "badness" x loc))))
 585                        (reverse vars))
 586              (comp-tail body)
 587              (emit-code #f (make-glil-unbind))))))))))