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 #f 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 self-label 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           ;; emit label for self tail calls
 197           (if self-label
 198               (emit-code #f (make-glil-label self-label)))
 199           ;; write bindings and source debugging info
 200           (emit-bindings #f ids vars allocation x emit-code)
 201           (if (lambda-src x)
 202               (emit-code #f (make-glil-source (lambda-src x))))
 203           ;; box args if necessary
 204           (for-each
 205            (lambda (v)
 206              (pmatch (hashq-ref (hashq-ref allocation v) x)
 207                      ((#t #t . ,n)
 208                       (emit-code #f (make-glil-lexical #t #f 'ref n))
 209                       (emit-code #f (make-glil-lexical #t #t 'box n)))))
 210            vars)
 211           ;; and here, here, dear reader: we compile.
 212           (flatten (lambda-body x) allocation x self-label emit-code)))))))
 213
 214 (define (flatten x allocation self self-label emit-code)
 215   (define (emit-label label)
 216     (emit-code #f (make-glil-label label)))
 217   (define (emit-branch src inst label)
 218     (emit-code src (make-glil-branch inst label)))
 219
 220   ;; LMVRA == "let-values MV return address"
 221   (let comp ((x x) (context 'tail) (LMVRA #f))
 222     (define (comp-tail tree) (comp tree context LMVRA))
 223     (define (comp-push tree) (comp tree 'push #f))
 224     (define (comp-drop tree) (comp tree 'drop #f))
 225     (define (comp-vals tree LMVRA) (comp tree 'vals LMVRA))
 226
 227     (record-case x
 228       ((<void>)
 229        (case context
 230          ((push vals) (emit-code #f (make-glil-void)))
 231          ((tail)
 232           (emit-code #f (make-glil-void))
 233           (emit-code #f (make-glil-call 'return 1)))))
 234
 235       ((<const> src exp)
 236        (case context
 237          ((push vals) (emit-code src (make-glil-const exp)))
 238          ((tail)
 239           (emit-code src (make-glil-const exp))
 240           (emit-code #f (make-glil-call 'return 1)))))
 241
 242       ;; FIXME: should represent sequence as exps tail
 243       ((<sequence> src exps)
 244        (let lp ((exps exps))
 245          (if (null? (cdr exps))
 246              (comp-tail (car exps))
 247              (begin
 248                (comp-drop (car exps))
 249                (lp (cdr exps))))))
 250
 251       ((<application> src proc args)
 252        ;; FIXME: need a better pattern-matcher here
 253        (cond
 254         ((and (primitive-ref? proc)
 255               (eq? (primitive-ref-name proc) '@apply)
 256               (>= (length args) 1))
 257          (let ((proc (car args))
 258                (args (cdr args)))
 259            (cond
 260             ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 261                   (not (eq? context 'push)) (not (eq? context 'vals)))
 262              ;; tail: (lambda () (apply values '(1 2)))
 263              ;; drop: (lambda () (apply values '(1 2)) 3)
 264              ;; push: (lambda () (list (apply values '(10 12)) 1))
 265              (case context
 266                ((drop) (for-each comp-drop args))
 267                ((tail)
 268                 (for-each comp-push args)
 269                 (emit-code src (make-glil-call 'return/values* (length args))))))
 270
 271             (else
 272              (case context
 273                ((tail)
 274                 (comp-push proc)
 275                 (for-each comp-push args)
 276                 (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
 277                ((push)
 278                 (comp-push proc)
 279                 (for-each comp-push args)
 280                 (emit-code src (make-glil-call 'apply (1+ (length args)))))
 281                ((vals)
 282                 (comp-vals
 283                  (make-application src (make-primitive-ref #f 'apply)
 284                                    (cons proc args))
 285                  LMVRA))
 286                ((drop)
 287                 ;; Well, shit. The proc might return any number of
 288                 ;; values (including 0), since it's in a drop context,
 289                 ;; yet apply does not create a MV continuation. So we
 290                 ;; mv-call out to our trampoline instead.
 291                 (comp-drop
 292                  (make-application src (make-primitive-ref #f 'apply)
 293                                    (cons proc args)))))))))
 294
 295         ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 296               (not (eq? context 'push)))
 297          ;; tail: (lambda () (values '(1 2)))
 298          ;; drop: (lambda () (values '(1 2)) 3)
 299          ;; push: (lambda () (list (values '(10 12)) 1))
 300          ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
 301          (case context
 302            ((drop) (for-each comp-drop args))
 303            ((vals)
 304             (for-each comp-push args)
 305             (emit-code #f (make-glil-const (length args)))
 306             (emit-branch src 'br LMVRA))
 307            ((tail)
 308             (for-each comp-push args)
 309             (emit-code src (make-glil-call 'return/values (length args))))))
 310
 311         ((and (primitive-ref? proc)
 312               (eq? (primitive-ref-name proc) '@call-with-values)
 313               (= (length args) 2))
 314          ;; CONSUMER
 315          ;; PRODUCER
 316          ;; (mv-call MV)
 317          ;; ([tail]-call 1)
 318          ;; goto POST
 319          ;; MV: [tail-]call/nargs
 320          ;; POST: (maybe-drop)
 321          (case context
 322            ((vals)
 323             ;; Fall back.
 324             (comp-vals
 325              (make-application src (make-primitive-ref #f 'call-with-values)
 326                                args)
 327              LMVRA))
 328            (else
 329             (let ((MV (make-label)) (POST (make-label))
 330                   (producer (car args)) (consumer (cadr args)))
 331               (comp-push consumer)
 332               (comp-push producer)
 333               (emit-code src (make-glil-mv-call 0 MV))
 334               (case context
 335                 ((tail) (emit-code src (make-glil-call 'goto/args 1)))
 336                 (else   (emit-code src (make-glil-call 'call 1))
 337                         (emit-branch #f 'br POST)))
 338               (emit-label MV)
 339               (case context
 340                 ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
 341                 (else   (emit-code src (make-glil-call 'call/nargs 0))
 342                         (emit-label POST)
 343                         (if (eq? context 'drop)
 344                             (emit-code #f (make-glil-call 'drop 1)))))))))
 345
 346         ((and (primitive-ref? proc)
 347               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
 348               (= (length args) 1))
 349          (case context
 350            ((tail)
 351             (comp-push (car args))
 352             (emit-code src (make-glil-call 'goto/cc 1)))
 353            ((vals)
 354             (comp-vals
 355              (make-application
 356               src (make-primitive-ref #f 'call-with-current-continuation)
 357               args)
 358              LMVRA))
 359            ((push)
 360             (comp-push (car args))
 361             (emit-code src (make-glil-call 'call/cc 1)))
 362            ((drop)
 363             ;; Crap. Just like `apply' in drop context.
 364             (comp-drop
 365              (make-application
 366               src (make-primitive-ref #f 'call-with-current-continuation)
 367               args)))))
 368
 369         ((and (primitive-ref? proc)
 370               (or (hash-ref *primcall-ops*
 371                             (cons (primitive-ref-name proc) (length args)))
 372                   (hash-ref *primcall-ops* (primitive-ref-name proc))))
 373          => (lambda (op)
 374               (for-each comp-push args)
 375               (emit-code src (make-glil-call op (length args)))
 376               (case (instruction-pushes op)
 377                 ((0)
 378                  (case context
 379                    ((tail) (emit-code #f (make-glil-void))
 380                            (emit-code #f (make-glil-call 'return 1)))
 381                    ((push vals) (emit-code #f (make-glil-void)))))
 382                 ((1)
 383                  (case context
 384                    ((tail) (emit-code #f (make-glil-call 'return 1)))
 385                    ((drop) (emit-code #f (make-glil-call 'drop 1)))))
 386                 (else
 387                  (error "bad primitive op: too many pushes"
 388                         op (instruction-pushes op))))))
 389
 390         ;; da capo al fine
 391         ((and (lexical-ref? proc)
 392               self-label (eq? (lexical-ref-gensym proc) self-label)
 393               ;; self-call in tail position is a goto
 394               (eq? context 'tail)
 395               ;; make sure the arity is right
 396               (list? (lambda-vars self))
 397               (= (length args) (length (lambda-vars self))))
 398          ;; evaluate new values
 399          (for-each comp-push args)
 400          ;; rename & goto
 401          (for-each (lambda (sym)
 402                      (pmatch (hashq-ref (hashq-ref allocation sym) self)
 403                        ((#t ,boxed? . ,index)
 404                         (emit-code #f (make-glil-lexical #t #f 'set index)))
 405                        (,x (error "what" x))))
 406                    (reverse (lambda-vars self)))
 407          (emit-branch src 'br self-label))
 408
 409         (else
 410          (comp-push proc)
 411          (for-each comp-push args)
 412          (let ((len (length args)))
 413            (case context
 414              ((tail) (emit-code src (make-glil-call 'goto/args len)))
 415              ((push) (emit-code src (make-glil-call 'call len)))
 416              ((vals) (emit-code src (make-glil-mv-call len LMVRA)))
 417              ((drop)
 418               (let ((MV (make-label)) (POST (make-label)))
 419                 (emit-code src (make-glil-mv-call len MV))
 420                 (emit-code #f (make-glil-call 'drop 1))
 421                 (emit-branch #f 'br POST)
 422                 (emit-label MV)
 423                 (emit-code #f (make-glil-mv-bind '() #f))
 424                 (emit-code #f (make-glil-unbind))
 425                 (emit-label POST))))))))
 426
 427       ((<conditional> src test then else)
 428        ;;     TEST
 429        ;;     (br-if-not L1)
 430        ;;     THEN
 431        ;;     (br L2)
 432        ;; L1: ELSE
 433        ;; L2:
 434        (let ((L1 (make-label)) (L2 (make-label)))
 435          (comp-push test)
 436          (emit-branch src 'br-if-not L1)
 437          (comp-tail then)
 438          (if (not (eq? context 'tail))
 439              (emit-branch #f 'br L2))
 440          (emit-label L1)
 441          (comp-tail else)
 442          (if (not (eq? context 'tail))
 443              (emit-label L2))))
 444
 445       ((<primitive-ref> src name)
 446        (cond
 447         ((eq? (module-variable (fluid-ref *comp-module*) name)
 448               (module-variable the-root-module name))
 449          (case context
 450            ((push vals)
 451             (emit-code src (make-glil-toplevel 'ref name)))
 452            ((tail)
 453             (emit-code src (make-glil-toplevel 'ref name))
 454             (emit-code #f (make-glil-call 'return 1)))))
 455         (else
 456          (pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
 457          (case context
 458            ((push vals)
 459             (emit-code src (make-glil-module 'ref '(guile) name #f)))
 460            ((tail)
 461             (emit-code src (make-glil-module 'ref '(guile) name #f))
 462             (emit-code #f (make-glil-call 'return 1)))))))
 463
 464       ((<lexical-ref> src name gensym)
 465        (case context
 466          ((push vals tail)
 467           (pmatch (hashq-ref (hashq-ref allocation gensym) self)
 468             ((,local? ,boxed? . ,index)
 469              (emit-code src (make-glil-lexical local? boxed? 'ref index)))
 470             (,loc
 471              (error "badness" x loc)))))
 472        (case context
 473          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 474
 475       ((<lexical-set> src name gensym exp)
 476        (comp-push exp)
 477        (pmatch (hashq-ref (hashq-ref allocation gensym) self)
 478          ((,local? ,boxed? . ,index)
 479           (emit-code src (make-glil-lexical local? boxed? 'set index)))
 480          (,loc
 481           (error "badness" x loc)))
 482        (case context
 483          ((push vals)
 484           (emit-code #f (make-glil-void)))
 485          ((tail)
 486           (emit-code #f (make-glil-void))
 487           (emit-code #f (make-glil-call 'return 1)))))
 488
 489       ((<module-ref> src mod name public?)
 490        (emit-code src (make-glil-module 'ref mod name public?))
 491        (case context
 492          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 493          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 494
 495       ((<module-set> src mod name public? exp)
 496        (comp-push exp)
 497        (emit-code src (make-glil-module 'set mod name public?))
 498        (case context
 499          ((push vals)
 500           (emit-code #f (make-glil-void)))
 501          ((tail)
 502           (emit-code #f (make-glil-void))
 503           (emit-code #f (make-glil-call 'return 1)))))
 504
 505       ((<toplevel-ref> src name)
 506        (emit-code src (make-glil-toplevel 'ref name))
 507        (case context
 508          ((drop) (emit-code #f (make-glil-call 'drop 1)))
 509          ((tail) (emit-code #f (make-glil-call 'return 1)))))
 510
 511       ((<toplevel-set> src name exp)
 512        (comp-push exp)
 513        (emit-code src (make-glil-toplevel 'set name))
 514        (case context
 515          ((push vals)
 516           (emit-code #f (make-glil-void)))
 517          ((tail)
 518           (emit-code #f (make-glil-void))
 519           (emit-code #f (make-glil-call 'return 1)))))
 520
 521       ((<toplevel-define> src name exp)
 522        (comp-push exp)
 523        (emit-code src (make-glil-toplevel 'define name))
 524        (case context
 525          ((push vals)
 526           (emit-code #f (make-glil-void)))
 527          ((tail)
 528           (emit-code #f (make-glil-void))
 529           (emit-code #f (make-glil-call 'return 1)))))
 530
 531       ((<lambda>)
 532        (let ((free-locs (cddr (hashq-ref allocation x))))
 533          (case context
 534            ((push vals tail)
 535             (emit-code #f (flatten-lambda x #f allocation))
 536             (if (not (null? free-locs))
 537                 (begin
 538                   (for-each
 539                    (lambda (loc)
 540                      (pmatch loc
 541                        ((,local? ,boxed? . ,n)
 542                         (emit-code #f (make-glil-lexical local? #f 'ref n)))
 543                        (else (error "what" x loc))))
 544                    free-locs)
 545                   (emit-code #f (make-glil-call 'vector (length free-locs)))
 546                   (emit-code #f (make-glil-call 'make-closure 2))))
 547             (if (eq? context 'tail)
 548                 (emit-code #f (make-glil-call 'return 1)))))))
 549
 550       ((<let> src names vars vals body)
 551        (for-each comp-push vals)
 552        (emit-bindings src names vars allocation self emit-code)
 553        (for-each (lambda (v)
 554                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 555                      ((#t #f . ,n)
 556                       (emit-code src (make-glil-lexical #t #f 'set n)))
 557                      ((#t #t . ,n)
 558                       (emit-code src (make-glil-lexical #t #t 'box n)))
 559                      (,loc (error "badness" x loc))))
 560                  (reverse vars))
 561        (comp-tail body)
 562        (emit-code #f (make-glil-unbind)))
 563
 564       ((<letrec> src names vars vals body)
 565        (for-each (lambda (v)
 566                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 567                      ((#t #t . ,n)
 568                       (emit-code src (make-glil-lexical #t #t 'empty-box n)))
 569                      (,loc (error "badness" x loc))))
 570                  vars)
 571        (for-each comp-push vals)
 572        (emit-bindings src names vars allocation self emit-code)
 573        (for-each (lambda (v)
 574                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 575                      ((#t #t . ,n)
 576                       (emit-code src (make-glil-lexical #t #t 'set n)))
 577                      (,loc (error "badness" x loc))))
 578                  (reverse vars))
 579        (comp-tail body)
 580        (emit-code #f (make-glil-unbind)))
 581
 582       ((<fix> src names vars vals body)
 583        ;; For fixpoint procedures, we can do some tricks to avoid
 584        ;; heap-allocation. Since we know the vals are lambdas, we can
 585        ;; set them to their local var slots first, then capture their
 586        ;; bindings, mutating them in place.
 587        (for-each (lambda (x v)
 588                    (emit-code #f (flatten-lambda x v allocation))
 589                    (if (not (null? (cddr (hashq-ref allocation x))))
 590                        ;; But we do have to make-closure them first, so
 591                        ;; we are mutating fresh closures on the heap.
 592                        (begin
 593                          (emit-code #f (make-glil-const #f))
 594                          (emit-code #f (make-glil-call 'make-closure 2))))
 595                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 596                      ((#t #f . ,n)
 597                       (emit-code src (make-glil-lexical #t #f 'set n)))
 598                      (,loc (error "badness" x loc))))
 599                  vals
 600                  vars)
 601        (emit-bindings src names vars allocation self emit-code)
 602        ;; Now go back and fix up the bindings.
 603        (for-each
 604         (lambda (x v)
 605           (let ((free-locs (cddr (hashq-ref allocation x))))
 606             (if (not (null? free-locs))
 607                 (begin
 608                   (for-each
 609                    (lambda (loc)
 610                      (pmatch loc
 611                        ((,local? ,boxed? . ,n)
 612                         (emit-code #f (make-glil-lexical local? #f 'ref n)))
 613                        (else (error "what" x loc))))
 614                    free-locs)
 615                   (emit-code #f (make-glil-call 'vector (length free-locs)))
 616                   (pmatch (hashq-ref (hashq-ref allocation v) self)
 617                     ((#t #f . ,n)
 618                      (emit-code #f (make-glil-lexical #t #f 'fix n)))
 619                     (,loc (error "badness" x loc)))))))
 620         vals
 621         vars)
 622        (comp-tail body)
 623        (emit-code #f (make-glil-unbind)))
 624
 625       ((<let-values> src names vars exp body)
 626        (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
 627          (cond
 628           ((pair? inames)
 629            (lp (cons (car inames) names) (cons (car ivars) vars)
 630                (cdr inames) (cdr ivars) #f))
 631           ((not (null? inames))
 632            (lp (cons inames names) (cons ivars vars) '() '() #t))
 633           (else
 634            (let ((names (reverse! names))
 635                  (vars (reverse! vars))
 636                  (MV (make-label)))
 637              (comp-vals exp MV)
 638              (emit-code #f (make-glil-const 1))
 639              (emit-label MV)
 640              (emit-code src (make-glil-mv-bind
 641                              (vars->bind-list names vars allocation self)
 642                              rest?))
 643              (for-each (lambda (v)
 644                          (pmatch (hashq-ref (hashq-ref allocation v) self)
 645                            ((#t #f . ,n)
 646                             (emit-code src (make-glil-lexical #t #f 'set n)))
 647                            ((#t #t . ,n)
 648                             (emit-code src (make-glil-lexical #t #t 'box n)))
 649                            (,loc (error "badness" x loc))))
 650                        (reverse vars))
 651              (comp-tail body)
 652              (emit-code #f (make-glil-unbind))))))))))