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 ;; allocation:
  34 ;;  sym -> {lambda -> address}
  35 ;;  lambda -> (nlocs labels . free-locs)
  36 ;;
  37 ;; address := (local? boxed? . index)
  38 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
  39 ;; free variable addresses are relative to parent proc.
  40
  41 (define *comp-module* (make-fluid))
  42
  43 (define %warning-passes
  44   `((unused-variable     . ,report-unused-variables)
  45     (unbound-variable    . ,report-possibly-unbound-variables)))
  46
  47 (define (compile-glil x e opts)
  48   (define warnings
  49     (or (and=> (memq #:warnings opts) cadr)
  50         '()))
  51
  52   ;; Go through the warning passes.
  53   (for-each (lambda (kind)
  54                 (let ((warn (assoc-ref %warning-passes kind)))
  55                   (and (procedure? warn)
  56                        (warn x e))))
  57             warnings)
  58
  59   (let* ((x (make-lambda (tree-il-src x) '() '() '() x))
  60          (x (optimize! x e opts))
  61          (allocation (analyze-lexicals x)))
  62
  63     (with-fluid* *comp-module* e
  64       (lambda ()
  65         (values (flatten-lambda x #f allocation)
  66                 e
  67                 e)))))
  68
  69 \f
  70
  71 (define *primcall-ops* (make-hash-table))
  72 (for-each
  73  (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
  74  '(((eq? . 2) . eq?)
  75    ((eqv? . 2) . eqv?)
  76    ((equal? . 2) . equal?)
  77    ((= . 2) . ee?)
  78    ((< . 2) . lt?)
  79    ((> . 2) . gt?)
  80    ((<= . 2) . le?)
  81    ((>= . 2) . ge?)
  82    ((+ . 2) . add)
  83    ((- . 2) . sub)
  84    ((1+ . 1) . add1)
  85    ((1- . 1) . sub1)
  86    ((* . 2) . mul)
  87    ((/ . 2) . div)
  88    ((quotient . 2) . quo)
  89    ((remainder . 2) . rem)
  90    ((modulo . 2) . mod)
  91    ((not . 1) . not)
  92    ((pair? . 1) . pair?)
  93    ((cons . 2) . cons)
  94    ((car . 1) . car)
  95    ((cdr . 1) . cdr)
  96    ((set-car! . 2) . set-car!)
  97    ((set-cdr! . 2) . set-cdr!)
  98    ((null? . 1) . null?)
  99    ((list? . 1) . list?)
 100    (list . list)
 101    (vector . vector)
 102    ((@slot-ref . 2) . slot-ref)
 103    ((@slot-set! . 3) . slot-set)
 104    ((vector-ref . 2) . vector-ref)
 105    ((vector-set! . 3) . vector-set)
 106
 107    ((bytevector-u8-ref . 2) . bv-u8-ref)
 108    ((bytevector-u8-set! . 3) . bv-u8-set)
 109    ((bytevector-s8-ref . 2) . bv-s8-ref)
 110    ((bytevector-s8-set! . 3) . bv-s8-set)
 111
 112    ((bytevector-u16-ref . 3) . bv-u16-ref)
 113    ((bytevector-u16-set! . 4) . bv-u16-set)
 114    ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
 115    ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
 116    ((bytevector-s16-ref . 3) . bv-s16-ref)
 117    ((bytevector-s16-set! . 4) . bv-s16-set)
 118    ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
 119    ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
 120
 121    ((bytevector-u32-ref . 3) . bv-u32-ref)
 122    ((bytevector-u32-set! . 4) . bv-u32-set)
 123    ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
 124    ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
 125    ((bytevector-s32-ref . 3) . bv-s32-ref)
 126    ((bytevector-s32-set! . 4) . bv-s32-set)
 127    ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
 128    ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
 129
 130    ((bytevector-u64-ref . 3) . bv-u64-ref)
 131    ((bytevector-u64-set! . 4) . bv-u64-set)
 132    ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
 133    ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
 134    ((bytevector-s64-ref . 3) . bv-s64-ref)
 135    ((bytevector-s64-set! . 4) . bv-s64-set)
 136    ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
 137    ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
 138
 139    ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
 140    ((bytevector-ieee-single-set! . 4) . bv-f32-set)
 141    ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
 142    ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
 143    ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
 144    ((bytevector-ieee-double-set! . 4) . bv-f64-set)
 145    ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
 146    ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
 147
 148
 149 \f
 150
 151 (define (make-label) (gensym ":L"))
 152
 153 (define (vars->bind-list ids vars allocation proc)
 154   (map (lambda (id v)
 155          (pmatch (hashq-ref (hashq-ref allocation v) proc)
 156            ((#t ,boxed? . ,n)
 157             (list id boxed? n))
 158            (,x (error "badness" x))))
 159        ids
 160        vars))
 161
 162 (define (emit-bindings src ids vars allocation proc emit-code)
 163   (emit-code src (make-glil-bind
 164                   (vars->bind-list ids vars allocation proc))))
 165
 166 (define (with-output-to-code proc)
 167   (let ((out '()))
 168     (define (emit-code src x)
 169       (set! out (cons x out))
 170       (if src
 171           (set! out (cons (make-glil-source src) out))))
 172     (proc emit-code)
 173     (reverse out)))
 174
 175 (define (flatten-lambda x self-label allocation)
 176   (receive (ids vars nargs nrest)
 177       (let lp ((ids (lambda-names x)) (vars (lambda-vars x))
 178                (oids '()) (ovars '()) (n 0))
 179           (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
 180                 ((pair? vars) (lp (cdr ids) (cdr vars)
 181                                   (cons (car ids) oids) (cons (car vars) ovars)
 182                                   (1+ n)))
 183                 (else (values (reverse (cons ids oids))
 184                               (reverse (cons vars ovars))
 185                               (1+ n) 1))))
 186     (let ((nlocs (car (hashq-ref allocation x)))
 187           (labels (cadr (hashq-ref allocation x))))
 188       (make-glil-program
 189        nargs nrest nlocs (lambda-meta x)
 190        (with-output-to-code
 191         (lambda (emit-code)
 192           ;; emit label for self tail calls
 193           (if self-label
 194               (emit-code #f (make-glil-label self-label)))
 195           ;; write bindings and source debugging info
 196           (if (not (null? ids))
 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 self-label
 210                    labels emit-code)))))))
 211
 212 (define (flatten x allocation self self-label fix-labels emit-code)
 213   (define (emit-label label)
 214     (emit-code #f (make-glil-label label)))
 215   (define (emit-branch src inst label)
 216     (emit-code src (make-glil-branch inst label)))
 217
 218   ;; RA: "return address"; #f unless we're in a non-tail fix with labels
 219   ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
 220   (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
 221     (define (comp-tail tree) (comp tree context RA MVRA))
 222     (define (comp-push tree) (comp tree 'push #f #f))
 223     (define (comp-drop tree) (comp tree 'drop #f #f))
 224     (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
 225     (define (comp-fix tree RA) (comp tree context RA MVRA))
 226
 227     ;; A couple of helpers. Note that if we are in tail context, we
 228     ;; won't have an RA.
 229     (define (maybe-emit-return)
 230       (if RA
 231           (emit-branch #f 'br RA)
 232           (if (eq? context 'tail)
 233               (emit-code #f (make-glil-call 'return 1)))))
 234
 235     (record-case x
 236       ((<void>)
 237        (case context
 238          ((push vals tail)
 239           (emit-code #f (make-glil-void))))
 240        (maybe-emit-return))
 241
 242       ((<const> src exp)
 243        (case context
 244          ((push vals tail)
 245           (emit-code src (make-glil-const exp))))
 246        (maybe-emit-return))
 247
 248       ;; FIXME: should represent sequence as exps tail
 249       ((<sequence> exps)
 250        (let lp ((exps exps))
 251          (if (null? (cdr exps))
 252              (comp-tail (car exps))
 253              (begin
 254                (comp-drop (car exps))
 255                (lp (cdr exps))))))
 256
 257       ((<application> src proc args)
 258        ;; FIXME: need a better pattern-matcher here
 259        (cond
 260         ((and (primitive-ref? proc)
 261               (eq? (primitive-ref-name proc) '@apply)
 262               (>= (length args) 1))
 263          (let ((proc (car args))
 264                (args (cdr args)))
 265            (cond
 266             ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 267                   (not (eq? context 'push)) (not (eq? context 'vals)))
 268              ;; tail: (lambda () (apply values '(1 2)))
 269              ;; drop: (lambda () (apply values '(1 2)) 3)
 270              ;; push: (lambda () (list (apply values '(10 12)) 1))
 271              (case context
 272                ((drop) (for-each comp-drop args) (maybe-emit-return))
 273                ((tail)
 274                 (for-each comp-push args)
 275                 (emit-code src (make-glil-call 'return/values* (length args))))))
 276
 277             (else
 278              (case context
 279                ((tail)
 280                 (comp-push proc)
 281                 (for-each comp-push args)
 282                 (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
 283                ((push)
 284                 (emit-code src (make-glil-call 'new-frame 0))
 285                 (comp-push proc)
 286                 (for-each comp-push args)
 287                 (emit-code src (make-glil-call 'apply (1+ (length args))))
 288                 (maybe-emit-return))
 289                ((vals)
 290                 (comp-vals
 291                  (make-application src (make-primitive-ref #f 'apply)
 292                                    (cons proc args))
 293                  MVRA)
 294                 (maybe-emit-return))
 295                ((drop)
 296                 ;; Well, shit. The proc might return any number of
 297                 ;; values (including 0), since it's in a drop context,
 298                 ;; yet apply does not create a MV continuation. So we
 299                 ;; mv-call out to our trampoline instead.
 300                 (comp-drop
 301                  (make-application src (make-primitive-ref #f 'apply)
 302                                    (cons proc args)))
 303                 (maybe-emit-return)))))))
 304
 305         ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 306               (not (eq? context 'push)))
 307          ;; tail: (lambda () (values '(1 2)))
 308          ;; drop: (lambda () (values '(1 2)) 3)
 309          ;; push: (lambda () (list (values '(10 12)) 1))
 310          ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
 311          (case context
 312            ((drop) (for-each comp-drop args) (maybe-emit-return))
 313            ((vals)
 314             (for-each comp-push args)
 315             (emit-code #f (make-glil-const (length args)))
 316             (emit-branch src 'br MVRA))
 317            ((tail)
 318             (for-each comp-push args)
 319             (emit-code src (make-glil-call 'return/values (length args))))))
 320
 321         ((and (primitive-ref? proc)
 322               (eq? (primitive-ref-name proc) '@call-with-values)
 323               (= (length args) 2))
 324          ;; CONSUMER
 325          ;; PRODUCER
 326          ;; (mv-call MV)
 327          ;; ([tail]-call 1)
 328          ;; goto POST
 329          ;; MV: [tail-]call/nargs
 330          ;; POST: (maybe-drop)
 331          (case context
 332            ((vals)
 333             ;; Fall back.
 334             (comp-vals
 335              (make-application src (make-primitive-ref #f 'call-with-values)
 336                                args)
 337              MVRA)
 338             (maybe-emit-return))
 339            (else
 340             (let ((MV (make-label)) (POST (make-label))
 341                   (producer (car args)) (consumer (cadr args)))
 342               (if (not (eq? context 'tail))
 343                   (emit-code src (make-glil-call 'new-frame 0)))
 344               (comp-push consumer)
 345               (emit-code src (make-glil-call 'new-frame 0))
 346               (comp-push producer)
 347               (emit-code src (make-glil-mv-call 0 MV))
 348               (case context
 349                 ((tail) (emit-code src (make-glil-call 'goto/args 1)))
 350                 (else   (emit-code src (make-glil-call 'call 1))
 351                         (emit-branch #f 'br POST)))
 352               (emit-label MV)
 353               (case context
 354                 ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
 355                 (else   (emit-code src (make-glil-call 'call/nargs 0))
 356                         (emit-label POST)
 357                         (if (eq? context 'drop)
 358                             (emit-code #f (make-glil-call 'drop 1)))
 359                         (maybe-emit-return)))))))
 360
 361         ((and (primitive-ref? proc)
 362               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
 363               (= (length args) 1))
 364          (case context
 365            ((tail)
 366             (comp-push (car args))
 367             (emit-code src (make-glil-call 'goto/cc 1)))
 368            ((vals)
 369             (comp-vals
 370              (make-application
 371               src (make-primitive-ref #f 'call-with-current-continuation)
 372               args)
 373              MVRA)
 374             (maybe-emit-return))
 375            ((push)
 376             (comp-push (car args))
 377             (emit-code src (make-glil-call 'call/cc 1))
 378             (maybe-emit-return))
 379            ((drop)
 380             ;; Crap. Just like `apply' in drop context.
 381             (comp-drop
 382              (make-application
 383               src (make-primitive-ref #f 'call-with-current-continuation)
 384               args))
 385             (maybe-emit-return))))
 386
 387         ((and (primitive-ref? proc)
 388               (or (hash-ref *primcall-ops*
 389                             (cons (primitive-ref-name proc) (length args)))
 390                   (hash-ref *primcall-ops* (primitive-ref-name proc))))
 391          => (lambda (op)
 392               (for-each comp-push args)
 393               (emit-code src (make-glil-call op (length args)))
 394               (case (instruction-pushes op)
 395                 ((0)
 396                  (case context
 397                    ((tail push vals) (emit-code #f (make-glil-void))))
 398                  (maybe-emit-return))
 399                 ((1)
 400                  (case context
 401                    ((drop) (emit-code #f (make-glil-call 'drop 1))))
 402                  (maybe-emit-return))
 403                 (else
 404                  (error "bad primitive op: too many pushes"
 405                         op (instruction-pushes op))))))
 406
 407         ;; da capo al fine
 408         ((and (lexical-ref? proc)
 409               self-label (eq? (lexical-ref-gensym proc) self-label)
 410               ;; self-call in tail position is a goto
 411               (eq? context 'tail)
 412               ;; make sure the arity is right
 413               (list? (lambda-vars self))
 414               (= (length args) (length (lambda-vars self))))
 415          ;; evaluate new values
 416          (for-each comp-push args)
 417          ;; rename & goto
 418          (for-each (lambda (sym)
 419                      (pmatch (hashq-ref (hashq-ref allocation sym) self)
 420                        ((#t ,boxed? . ,index)
 421                         ;; set unboxed, as the proc prelude will box if needed
 422                         (emit-code #f (make-glil-lexical #t #f 'set index)))
 423                        (,x (error "what" x))))
 424                    (reverse (lambda-vars self)))
 425          (emit-branch src 'br self-label))
 426
 427         ;; lambda, the ultimate goto
 428         ((and (lexical-ref? proc)
 429               (assq (lexical-ref-gensym proc) fix-labels))
 430          ;; evaluate new values, assuming that analyze-lexicals did its
 431          ;; job, and that the arity was right
 432          (for-each comp-push args)
 433          ;; rename
 434          (for-each (lambda (sym)
 435                      (pmatch (hashq-ref (hashq-ref allocation sym) self)
 436                        ((#t #f . ,index)
 437                         (emit-code #f (make-glil-lexical #t #f 'set index)))
 438                        ((#t #t . ,index)
 439                         (emit-code #f (make-glil-lexical #t #t 'box index)))
 440                        (,x (error "what" x))))
 441                    (reverse (assq-ref fix-labels (lexical-ref-gensym proc))))
 442          ;; goto!
 443          (emit-branch src 'br (lexical-ref-gensym proc)))
 444
 445         (else
 446          (if (not (eq? context 'tail))
 447              (emit-code src (make-glil-call 'new-frame 0)))
 448          (comp-push proc)
 449          (for-each comp-push args)
 450          (let ((len (length args)))
 451            (case context
 452              ((tail) (emit-code src (make-glil-call 'goto/args len)))
 453              ((push) (emit-code src (make-glil-call 'call len))
 454                      (maybe-emit-return))
 455              ((vals) (emit-code src (make-glil-mv-call len MVRA))
 456                      (maybe-emit-return))
 457              ((drop) (let ((MV (make-label)) (POST (make-label)))
 458                        (emit-code src (make-glil-mv-call len MV))
 459                        (emit-code #f (make-glil-call 'drop 1))
 460                        (emit-branch #f 'br (or RA POST))
 461                        (emit-label MV)
 462                        (emit-code #f (make-glil-mv-bind '() #f))
 463                        (emit-code #f (make-glil-unbind))
 464                        (if RA
 465                            (emit-branch #f 'br RA)
 466                            (emit-label POST)))))))))
 467
 468       ((<conditional> src test then else)
 469        ;;     TEST
 470        ;;     (br-if-not L1)
 471        ;;     THEN
 472        ;;     (br L2)
 473        ;; L1: ELSE
 474        ;; L2:
 475        (let ((L1 (make-label)) (L2 (make-label)))
 476          (comp-push test)
 477          (emit-branch src 'br-if-not L1)
 478          (comp-tail then)
 479          ;; if there is an RA, comp-tail will cause a jump to it -- just
 480          ;; have to clean up here if there is no RA.
 481          (if (and (not RA) (not (eq? context 'tail)))
 482              (emit-branch #f 'br L2))
 483          (emit-label L1)
 484          (comp-tail else)
 485          (if (and (not RA) (not (eq? context 'tail)))
 486              (emit-label L2))))
 487
 488       ((<primitive-ref> src name)
 489        (cond
 490         ((eq? (module-variable (fluid-ref *comp-module*) name)
 491               (module-variable the-root-module name))
 492          (case context
 493            ((tail push vals)
 494             (emit-code src (make-glil-toplevel 'ref name))))
 495          (maybe-emit-return))
 496         ((module-variable the-root-module name)
 497          (case context
 498            ((tail push vals)
 499             (emit-code src (make-glil-module 'ref '(guile) name #f))))
 500          (maybe-emit-return))
 501         (else
 502          (case context
 503            ((tail push vals)
 504             (emit-code src (make-glil-module
 505                             'ref (module-name (fluid-ref *comp-module*)) name #f))))
 506          (maybe-emit-return))))
 507
 508       ((<lexical-ref> src gensym)
 509        (case context
 510          ((push vals tail)
 511           (pmatch (hashq-ref (hashq-ref allocation gensym) self)
 512             ((,local? ,boxed? . ,index)
 513              (emit-code src (make-glil-lexical local? boxed? 'ref index)))
 514             (,loc
 515              (error "badness" x loc)))))
 516        (maybe-emit-return))
 517
 518       ((<lexical-set> src gensym exp)
 519        (comp-push exp)
 520        (pmatch (hashq-ref (hashq-ref allocation gensym) self)
 521          ((,local? ,boxed? . ,index)
 522           (emit-code src (make-glil-lexical local? boxed? 'set index)))
 523          (,loc
 524           (error "badness" x loc)))
 525        (case context
 526          ((tail push vals)
 527           (emit-code #f (make-glil-void))))
 528        (maybe-emit-return))
 529
 530       ((<module-ref> src mod name public?)
 531        (emit-code src (make-glil-module 'ref mod name public?))
 532        (case context
 533          ((drop) (emit-code #f (make-glil-call 'drop 1))))
 534        (maybe-emit-return))
 535
 536       ((<module-set> src mod name public? exp)
 537        (comp-push exp)
 538        (emit-code src (make-glil-module 'set mod name public?))
 539        (case context
 540          ((tail push vals)
 541           (emit-code #f (make-glil-void))))
 542        (maybe-emit-return))
 543
 544       ((<toplevel-ref> src name)
 545        (emit-code src (make-glil-toplevel 'ref name))
 546        (case context
 547          ((drop) (emit-code #f (make-glil-call 'drop 1))))
 548        (maybe-emit-return))
 549
 550       ((<toplevel-set> src name exp)
 551        (comp-push exp)
 552        (emit-code src (make-glil-toplevel 'set name))
 553        (case context
 554          ((tail push vals)
 555           (emit-code #f (make-glil-void))))
 556        (maybe-emit-return))
 557
 558       ((<toplevel-define> src name exp)
 559        (comp-push exp)
 560        (emit-code src (make-glil-toplevel 'define name))
 561        (case context
 562          ((tail push vals)
 563           (emit-code #f (make-glil-void))))
 564        (maybe-emit-return))
 565
 566       ((<lambda>)
 567        (let ((free-locs (cddr (hashq-ref allocation x))))
 568          (case context
 569            ((push vals tail)
 570             (emit-code #f (flatten-lambda x #f allocation))
 571             (if (not (null? free-locs))
 572                 (begin
 573                   (for-each
 574                    (lambda (loc)
 575                      (pmatch loc
 576                        ((,local? ,boxed? . ,n)
 577                         (emit-code #f (make-glil-lexical local? #f 'ref n)))
 578                        (else (error "what" x loc))))
 579                    free-locs)
 580                   (emit-code #f (make-glil-call 'vector (length free-locs)))
 581                   (emit-code #f (make-glil-call 'make-closure 2)))))))
 582        (maybe-emit-return))
 583
 584       ((<let> src names vars vals body)
 585        (for-each comp-push vals)
 586        (emit-bindings src names vars allocation self emit-code)
 587        (for-each (lambda (v)
 588                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 589                      ((#t #f . ,n)
 590                       (emit-code src (make-glil-lexical #t #f 'set n)))
 591                      ((#t #t . ,n)
 592                       (emit-code src (make-glil-lexical #t #t 'box n)))
 593                      (,loc (error "badness" x loc))))
 594                  (reverse vars))
 595        (comp-tail body)
 596        (emit-code #f (make-glil-unbind)))
 597
 598       ((<letrec> src names vars vals body)
 599        (for-each (lambda (v)
 600                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 601                      ((#t #t . ,n)
 602                       (emit-code src (make-glil-lexical #t #t 'empty-box n)))
 603                      (,loc (error "badness" x loc))))
 604                  vars)
 605        (for-each comp-push vals)
 606        (emit-bindings src names vars allocation self emit-code)
 607        (for-each (lambda (v)
 608                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 609                      ((#t #t . ,n)
 610                       (emit-code src (make-glil-lexical #t #t 'set n)))
 611                      (,loc (error "badness" x loc))))
 612                  (reverse vars))
 613        (comp-tail body)
 614        (emit-code #f (make-glil-unbind)))
 615
 616       ((<fix> src names vars vals body)
 617        ;; The ideal here is to just render the lambda bodies inline, and
 618        ;; wire the code together with gotos. We can do that if
 619        ;; analyze-lexicals has determined that a given var has "label"
 620        ;; allocation -- which is the case if it is in `fix-labels'.
 621        ;;
 622        ;; But even for closures that we can't inline, we can do some
 623        ;; tricks to avoid heap-allocation for the binding itself. Since
 624        ;; we know the vals are lambdas, we can set them to their local
 625        ;; var slots first, then capture their bindings, mutating them in
 626        ;; place.
 627        (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
 628          (for-each
 629           (lambda (x v)
 630             (cond
 631              ((hashq-ref allocation x)
 632               ;; allocating a closure
 633               (emit-code #f (flatten-lambda x v allocation))
 634               (if (not (null? (cddr (hashq-ref allocation x))))
 635                   ;; Need to make-closure first, but with a temporary #f
 636                   ;; free-variables vector, so we are mutating fresh
 637                   ;; closures on the heap.
 638                   (begin
 639                     (emit-code #f (make-glil-const #f))
 640                     (emit-code #f (make-glil-call 'make-closure 2))))
 641               (pmatch (hashq-ref (hashq-ref allocation v) self)
 642                 ((#t #f . ,n)
 643                  (emit-code src (make-glil-lexical #t #f 'set n)))
 644                 (,loc (error "badness" x loc))))
 645              (else
 646               ;; labels allocation: emit label & body, but jump over it
 647               (let ((POST (make-label)))
 648                 (emit-branch #f 'br POST)
 649                 (emit-label v)
 650                 ;; we know the lambda vars are a list
 651                 (emit-bindings #f (lambda-names x) (lambda-vars x)
 652                                allocation self emit-code)
 653                 (if (lambda-src x)
 654                     (emit-code #f (make-glil-source (lambda-src x))))
 655                 (comp-fix (lambda-body x) (or RA new-RA))
 656                 (emit-code #f (make-glil-unbind))
 657                 (emit-label POST)))))
 658           vals
 659           vars)
 660          ;; Emit bindings metadata for closures
 661          (let ((binds (let lp ((out '()) (vars vars) (names names))
 662                         (cond ((null? vars) (reverse! out))
 663                               ((assq (car vars) fix-labels)
 664                                (lp out (cdr vars) (cdr names)))
 665                               (else
 666                                (lp (acons (car vars) (car names) out)
 667                                    (cdr vars) (cdr names)))))))
 668            (emit-bindings src (map cdr binds) (map car binds)
 669                           allocation self emit-code))
 670          ;; Now go back and fix up the bindings for closures.
 671          (for-each
 672           (lambda (x v)
 673             (let ((free-locs (if (hashq-ref allocation x)
 674                                  (cddr (hashq-ref allocation x))
 675                                  ;; can hit this latter case for labels allocation
 676                                  '())))
 677               (if (not (null? free-locs))
 678                   (begin
 679                     (for-each
 680                      (lambda (loc)
 681                        (pmatch loc
 682                          ((,local? ,boxed? . ,n)
 683                           (emit-code #f (make-glil-lexical local? #f 'ref n)))
 684                          (else (error "what" x loc))))
 685                      free-locs)
 686                     (emit-code #f (make-glil-call 'vector (length free-locs)))
 687                     (pmatch (hashq-ref (hashq-ref allocation v) self)
 688                       ((#t #f . ,n)
 689                        (emit-code #f (make-glil-lexical #t #f 'fix n)))
 690                       (,loc (error "badness" x loc)))))))
 691           vals
 692           vars)
 693          (comp-tail body)
 694          (if new-RA
 695              (emit-label new-RA))
 696          (emit-code #f (make-glil-unbind))))
 697
 698       ((<let-values> src names vars exp body)
 699        (let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
 700          (cond
 701           ((pair? inames)
 702            (lp (cons (car inames) names) (cons (car ivars) vars)
 703                (cdr inames) (cdr ivars) #f))
 704           ((not (null? inames))
 705            (lp (cons inames names) (cons ivars vars) '() '() #t))
 706           (else
 707            (let ((names (reverse! names))
 708                  (vars (reverse! vars))
 709                  (MV (make-label)))
 710              (comp-vals exp MV)
 711              (emit-code #f (make-glil-const 1))
 712              (emit-label MV)
 713              (emit-code src (make-glil-mv-bind
 714                              (vars->bind-list names vars allocation self)
 715                              rest?))
 716              (for-each (lambda (v)
 717                          (pmatch (hashq-ref (hashq-ref allocation v) self)
 718                            ((#t #f . ,n)
 719                             (emit-code src (make-glil-lexical #t #f 'set n)))
 720                            ((#t #t . ,n)
 721                             (emit-code src (make-glil-lexical #t #t 'box n)))
 722                            (,loc (error "badness" x loc))))
 723                        (reverse vars))
 724              (comp-tail body)
 725              (emit-code #f (make-glil-unbind))))))))))