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