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   #:use-module ((srfi srfi-1) #:select (filter-map))
  32   #:export (compile-glil))
  33
  34 ;; allocation:
  35 ;;  sym -> {lambda -> address}
  36 ;;  lambda -> (labels . free-locs)
  37 ;;  lambda-case -> (gensym . nlocs)
  38 ;;
  39 ;; address ::= (local? boxed? . index)
  40 ;; labels ::= ((sym . lambda) ...)
  41 ;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
  42 ;; free variable addresses are relative to parent proc.
  43
  44 (define *comp-module* (make-fluid))
  45
  46 (define %warning-passes
  47   `((unused-variable     . ,unused-variable-analysis)
  48     (unbound-variable    . ,unbound-variable-analysis)
  49     (arity-mismatch      . ,arity-analysis)))
  50
  51 (define (compile-glil x e opts)
  52   (define warnings
  53     (or (and=> (memq #:warnings opts) cadr)
  54         '()))
  55
  56   ;; Go through the warning passes.
  57   (let ((analyses (filter-map (lambda (kind)
  58                                 (assoc-ref %warning-passes kind))
  59                               warnings)))
  60     (analyze-tree analyses x e))
  61
  62   (let* ((x (make-lambda (tree-il-src x) '()
  63                          (make-lambda-case #f '() #f #f #f '() '() x #f)))
  64          (x (optimize! x e opts))
  65          (allocation (analyze-lexicals x)))
  66
  67     (with-fluid* *comp-module* e
  68       (lambda ()
  69         (values (flatten-lambda x #f allocation)
  70                 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    ((class-of . 1) . class-of)
 107    ((@slot-ref . 2) . slot-ref)
 108    ((@slot-set! . 3) . slot-set)
 109    ((vector-ref . 2) . vector-ref)
 110    ((vector-set! . 3) . vector-set)
 111
 112    ;; hack for javascript
 113    ((return . 1) return)
 114
 115    ((bytevector-u8-ref . 2) . bv-u8-ref)
 116    ((bytevector-u8-set! . 3) . bv-u8-set)
 117    ((bytevector-s8-ref . 2) . bv-s8-ref)
 118    ((bytevector-s8-set! . 3) . bv-s8-set)
 119
 120    ((bytevector-u16-ref . 3) . bv-u16-ref)
 121    ((bytevector-u16-set! . 4) . bv-u16-set)
 122    ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
 123    ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
 124    ((bytevector-s16-ref . 3) . bv-s16-ref)
 125    ((bytevector-s16-set! . 4) . bv-s16-set)
 126    ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
 127    ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
 128
 129    ((bytevector-u32-ref . 3) . bv-u32-ref)
 130    ((bytevector-u32-set! . 4) . bv-u32-set)
 131    ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
 132    ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
 133    ((bytevector-s32-ref . 3) . bv-s32-ref)
 134    ((bytevector-s32-set! . 4) . bv-s32-set)
 135    ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
 136    ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
 137
 138    ((bytevector-u64-ref . 3) . bv-u64-ref)
 139    ((bytevector-u64-set! . 4) . bv-u64-set)
 140    ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
 141    ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
 142    ((bytevector-s64-ref . 3) . bv-s64-ref)
 143    ((bytevector-s64-set! . 4) . bv-s64-set)
 144    ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
 145    ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
 146
 147    ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
 148    ((bytevector-ieee-single-set! . 4) . bv-f32-set)
 149    ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
 150    ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
 151    ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
 152    ((bytevector-ieee-double-set! . 4) . bv-f64-set)
 153    ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
 154    ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
 155
 156
 157 \f
 158
 159 (define (make-label) (gensym ":L"))
 160
 161 (define (vars->bind-list ids vars allocation proc)
 162   (map (lambda (id v)
 163          (pmatch (hashq-ref (hashq-ref allocation v) proc)
 164            ((#t ,boxed? . ,n)
 165             (list id boxed? n))
 166            (,x (error "badness" x))))
 167        ids
 168        vars))
 169
 170 (define (emit-bindings src ids vars allocation proc emit-code)
 171   (emit-code src (make-glil-bind
 172                   (vars->bind-list ids vars allocation proc))))
 173
 174 (define (with-output-to-code proc)
 175   (let ((out '()))
 176     (define (emit-code src x)
 177       (set! out (cons x out))
 178       (if src
 179           (set! out (cons (make-glil-source src) out))))
 180     (proc emit-code)
 181     (reverse out)))
 182
 183 (define (flatten-lambda x self-label allocation)
 184   (record-case x
 185     ((<lambda> src meta body)
 186      (make-glil-program
 187       meta
 188       (with-output-to-code
 189        (lambda (emit-code)
 190          ;; write source info for proc
 191          (if src (emit-code #f (make-glil-source src)))
 192          ;; emit pre-prelude label for self tail calls in which the
 193          ;; number of arguments doesn't check out at compile time
 194          (if self-label
 195              (emit-code #f (make-glil-label self-label)))
 196          ;; compile the body, yo
 197          (flatten body allocation x self-label (car (hashq-ref allocation x))
 198                   emit-code)))))))
 199
 200 (define (flatten x allocation self self-label fix-labels emit-code)
 201   (define (emit-label label)
 202     (emit-code #f (make-glil-label label)))
 203   (define (emit-branch src inst label)
 204     (emit-code src (make-glil-branch inst label)))
 205
 206   ;; RA: "return address"; #f unless we're in a non-tail fix with labels
 207   ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
 208   (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
 209     (define (comp-tail tree) (comp tree context RA MVRA))
 210     (define (comp-push tree) (comp tree 'push #f #f))
 211     (define (comp-drop tree) (comp tree 'drop #f #f))
 212     (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
 213     (define (comp-fix tree RA) (comp tree context RA MVRA))
 214
 215     ;; A couple of helpers. Note that if we are in tail context, we
 216     ;; won't have an RA.
 217     (define (maybe-emit-return)
 218       (if RA
 219           (emit-branch #f 'br RA)
 220           (if (eq? context 'tail)
 221               (emit-code #f (make-glil-call 'return 1)))))
 222
 223     (record-case x
 224       ((<void>)
 225        (case context
 226          ((push vals tail)
 227           (emit-code #f (make-glil-void))))
 228        (maybe-emit-return))
 229
 230       ((<const> src exp)
 231        (case context
 232          ((push vals tail)
 233           (emit-code src (make-glil-const exp))))
 234        (maybe-emit-return))
 235
 236       ;; FIXME: should represent sequence as exps tail
 237       ((<sequence> exps)
 238        (let lp ((exps exps))
 239          (if (null? (cdr exps))
 240              (comp-tail (car exps))
 241              (begin
 242                (comp-drop (car exps))
 243                (lp (cdr exps))))))
 244
 245       ((<application> src proc args)
 246        ;; FIXME: need a better pattern-matcher here
 247        (cond
 248         ((and (primitive-ref? proc)
 249               (eq? (primitive-ref-name proc) '@apply)
 250               (>= (length args) 1))
 251          (let ((proc (car args))
 252                (args (cdr args)))
 253            (cond
 254             ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 255                   (not (eq? context 'push)) (not (eq? context 'vals)))
 256              ;; tail: (lambda () (apply values '(1 2)))
 257              ;; drop: (lambda () (apply values '(1 2)) 3)
 258              ;; push: (lambda () (list (apply values '(10 12)) 1))
 259              (case context
 260                ((drop) (for-each comp-drop args) (maybe-emit-return))
 261                ((tail)
 262                 (for-each comp-push args)
 263                 (emit-code src (make-glil-call 'return/values* (length args))))))
 264
 265             (else
 266              (case context
 267                ((tail)
 268                 (comp-push proc)
 269                 (for-each comp-push args)
 270                 (emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
 271                ((push)
 272                 (emit-code src (make-glil-call 'new-frame 0))
 273                 (comp-push proc)
 274                 (for-each comp-push args)
 275                 (emit-code src (make-glil-call 'apply (1+ (length args))))
 276                 (maybe-emit-return))
 277                ((vals)
 278                 (comp-vals
 279                  (make-application src (make-primitive-ref #f 'apply)
 280                                    (cons proc args))
 281                  MVRA)
 282                 (maybe-emit-return))
 283                ((drop)
 284                 ;; Well, shit. The proc might return any number of
 285                 ;; values (including 0), since it's in a drop context,
 286                 ;; yet apply does not create a MV continuation. So we
 287                 ;; mv-call out to our trampoline instead.
 288                 (comp-drop
 289                  (make-application src (make-primitive-ref #f 'apply)
 290                                    (cons proc args)))
 291                 (maybe-emit-return)))))))
 292
 293         ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 294               (not (eq? context 'push)))
 295          ;; tail: (lambda () (values '(1 2)))
 296          ;; drop: (lambda () (values '(1 2)) 3)
 297          ;; push: (lambda () (list (values '(10 12)) 1))
 298          ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
 299          (case context
 300            ((drop) (for-each comp-drop args) (maybe-emit-return))
 301            ((vals)
 302             (for-each comp-push args)
 303             (emit-code #f (make-glil-const (length args)))
 304             (emit-branch src 'br MVRA))
 305            ((tail)
 306             (for-each comp-push args)
 307             (emit-code src (make-glil-call 'return/values (length args))))))
 308
 309         ((and (primitive-ref? proc)
 310               (eq? (primitive-ref-name proc) '@call-with-values)
 311               (= (length args) 2))
 312          ;; CONSUMER
 313          ;; PRODUCER
 314          ;; (mv-call MV)
 315          ;; ([tail]-call 1)
 316          ;; goto POST
 317          ;; MV: [tail-]call/nargs
 318          ;; POST: (maybe-drop)
 319          (case context
 320            ((vals)
 321             ;; Fall back.
 322             (comp-vals
 323              (make-application src (make-primitive-ref #f 'call-with-values)
 324                                args)
 325              MVRA)
 326             (maybe-emit-return))
 327            (else
 328             (let ((MV (make-label)) (POST (make-label))
 329                   (producer (car args)) (consumer (cadr args)))
 330               (if (not (eq? context 'tail))
 331                   (emit-code src (make-glil-call 'new-frame 0)))
 332               (comp-push consumer)
 333               (emit-code src (make-glil-call 'new-frame 0))
 334               (comp-push producer)
 335               (emit-code src (make-glil-mv-call 0 MV))
 336               (case context
 337                 ((tail) (emit-code src (make-glil-call 'goto/args 1)))
 338                 (else   (emit-code src (make-glil-call 'call 1))
 339                         (emit-branch #f 'br POST)))
 340               (emit-label MV)
 341               (case context
 342                 ((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
 343                 (else   (emit-code src (make-glil-call 'call/nargs 0))
 344                         (emit-label POST)
 345                         (if (eq? context 'drop)
 346                             (emit-code #f (make-glil-call 'drop 1)))
 347                         (maybe-emit-return)))))))
 348
 349         ((and (primitive-ref? proc)
 350               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
 351               (= (length args) 1))
 352          (case context
 353            ((tail)
 354             (comp-push (car args))
 355             (emit-code src (make-glil-call 'goto/cc 1)))
 356            ((vals)
 357             (comp-vals
 358              (make-application
 359               src (make-primitive-ref #f 'call-with-current-continuation)
 360               args)
 361              MVRA)
 362             (maybe-emit-return))
 363            ((push)
 364             (comp-push (car args))
 365             (emit-code src (make-glil-call 'call/cc 1))
 366             (maybe-emit-return))
 367            ((drop)
 368             ;; Crap. Just like `apply' in drop context.
 369             (comp-drop
 370              (make-application
 371               src (make-primitive-ref #f 'call-with-current-continuation)
 372               args))
 373             (maybe-emit-return))))
 374
 375         ((and (primitive-ref? proc)
 376               (or (hash-ref *primcall-ops*
 377                             (cons (primitive-ref-name proc) (length args)))
 378                   (hash-ref *primcall-ops* (primitive-ref-name proc))))
 379          => (lambda (op)
 380               (for-each comp-push args)
 381               (emit-code src (make-glil-call op (length args)))
 382               (case (instruction-pushes op)
 383                 ((0)
 384                  (case context
 385                    ((tail push vals) (emit-code #f (make-glil-void))))
 386                  (maybe-emit-return))
 387                 ((1)
 388                  (case context
 389                    ((drop) (emit-code #f (make-glil-call 'drop 1))))
 390                  (maybe-emit-return))
 391                 (else
 392                  (error "bad primitive op: too many pushes"
 393                         op (instruction-pushes op))))))
 394
 395         ;; self-call in tail position
 396         ((and (lexical-ref? proc)
 397               self-label (eq? (lexical-ref-gensym proc) self-label)
 398               (eq? context 'tail))
 399          ;; first, evaluate new values, pushing them on the stack
 400          (for-each comp-push args)
 401          (let lp ((lcase (lambda-body self)))
 402            (cond
 403             ((and (lambda-case? lcase)
 404                   (not (lambda-case-kw lcase))
 405                   (not (lambda-case-opt lcase))
 406                   (not (lambda-case-rest lcase))
 407                   (= (length args) (length (lambda-case-req lcase))))
 408              ;; we have a case that matches the args; rename variables
 409              ;; and goto the case label
 410              (for-each (lambda (sym)
 411                          (pmatch (hashq-ref (hashq-ref allocation sym) self)
 412                            ((#t #f . ,index) ; unboxed
 413                             (emit-code #f (make-glil-lexical #t #f 'set index)))
 414                            ((#t #t . ,index) ; boxed
 415                             ;; new box
 416                             (emit-code #f (make-glil-lexical #t #t 'box index)))
 417                            (,x (error "what" x))))
 418                        (reverse (lambda-case-vars lcase)))
 419              (emit-branch src 'br (car (hashq-ref allocation lcase))))
 420             ((lambda-case? lcase)
 421              ;; no match, try next case
 422              (lp (lambda-case-else lcase)))
 423             (else
 424              ;; no cases left; shuffle args down and jump before the prelude.
 425              (for-each (lambda (i)
 426                          (emit-code #f (make-glil-lexical #t #f 'set i)))
 427                        (reverse (iota (length args))))
 428              (emit-branch src 'br self-label)))))
 429
 430         ;; lambda, the ultimate goto
 431         ((and (lexical-ref? proc)
 432               (assq (lexical-ref-gensym proc) fix-labels))
 433          ;; like the self-tail-call case, though we can handle "drop"
 434          ;; contexts too. first, evaluate new values, pushing them on
 435          ;; the stack
 436          (for-each comp-push args)
 437          ;; find the specific case, rename args, and goto the case label
 438          (let lp ((lcase (lambda-body
 439                           (assq-ref fix-labels (lexical-ref-gensym proc)))))
 440            (cond
 441             ((and (lambda-case? lcase)
 442                   (not (lambda-case-kw lcase))
 443                   (not (lambda-case-opt lcase))
 444                   (not (lambda-case-rest lcase))
 445                   (= (length args) (length (lambda-case-req lcase))))
 446              ;; we have a case that matches the args; rename variables
 447              ;; and goto the case label
 448              (for-each (lambda (sym)
 449                          (pmatch (hashq-ref (hashq-ref allocation sym) self)
 450                            ((#t #f . ,index) ; unboxed
 451                             (emit-code #f (make-glil-lexical #t #f 'set index)))
 452                            ((#t #t . ,index) ; boxed
 453                             (emit-code #f (make-glil-lexical #t #t 'box index)))
 454                            (,x (error "what" x))))
 455                        (reverse (lambda-case-vars lcase)))
 456              (emit-branch src 'br (car (hashq-ref allocation lcase))))
 457             ((lambda-case? lcase)
 458              ;; no match, try next case
 459              (lp (lambda-case-else lcase)))
 460             (else
 461              ;; no cases left. we can't really handle this currently.
 462              ;; ideally we would push on a new frame, then do a "local
 463              ;; call" -- which doesn't require consing up a program
 464              ;; object. but for now error, as this sort of case should
 465              ;; preclude label allocation.
 466              (error "couldn't find matching case for label call" x)))))
 467
 468         (else
 469          (if (not (eq? context 'tail))
 470              (emit-code src (make-glil-call 'new-frame 0)))
 471          (comp-push proc)
 472          (for-each comp-push args)
 473          (let ((len (length args)))
 474            (case context
 475              ((tail) (emit-code src (make-glil-call 'goto/args len)))
 476              ((push) (emit-code src (make-glil-call 'call len))
 477                      (maybe-emit-return))
 478              ((vals) (emit-code src (make-glil-mv-call len MVRA))
 479                      (maybe-emit-return))
 480              ((drop) (let ((MV (make-label)) (POST (make-label)))
 481                        (emit-code src (make-glil-mv-call len MV))
 482                        (emit-code #f (make-glil-call 'drop 1))
 483                        (emit-branch #f 'br (or RA POST))
 484                        (emit-label MV)
 485                        (emit-code #f (make-glil-mv-bind '() #f))
 486                        (emit-code #f (make-glil-unbind))
 487                        (if RA
 488                            (emit-branch #f 'br RA)
 489                            (emit-label POST)))))))))
 490
 491       ((<conditional> src test then (alternate else))
 492        ;;     TEST
 493        ;;     (br-if-not L1)
 494        ;;     THEN
 495        ;;     (br L2)
 496        ;; L1: ELSE
 497        ;; L2:
 498        (let ((L1 (make-label)) (L2 (make-label)))
 499          ;; need a pattern matcher
 500          (record-case test
 501            ((<application> proc args)
 502             (record-case proc
 503               ((<primitive-ref> name)
 504                (let ((len (length args)))
 505                  (cond
 506
 507                   ((and (eq? name 'eq?) (= len 2))
 508                    (comp-push (car args))
 509                    (comp-push (cadr args))
 510                    (emit-branch src 'br-if-not-eq L1))
 511
 512                   ((and (eq? name 'null?) (= len 1))
 513                    (comp-push (car args))
 514                    (emit-branch src 'br-if-not-null L1))
 515
 516                   ((and (eq? name 'not) (= len 1))
 517                    (let ((app (car args)))
 518                      (record-case app
 519                        ((<application> proc args)
 520                         (let ((len (length args)))
 521                           (record-case proc
 522                             ((<primitive-ref> name)
 523                              (cond
 524
 525                               ((and (eq? name 'eq?) (= len 2))
 526                                (comp-push (car args))
 527                                (comp-push (cadr args))
 528                                (emit-branch src 'br-if-eq L1))
 529
 530                               ((and (eq? name 'null?) (= len 1))
 531                                (comp-push (car args))
 532                                (emit-branch src 'br-if-null L1))
 533
 534                               (else
 535                                (comp-push app)
 536                                (emit-branch src 'br-if L1))))
 537                             (else
 538                              (comp-push app)
 539                              (emit-branch src 'br-if L1)))))
 540                        (else
 541                         (comp-push app)
 542                         (emit-branch src 'br-if L1)))))
 543
 544                   (else
 545                    (comp-push test)
 546                    (emit-branch src 'br-if-not L1)))))
 547               (else
 548                (comp-push test)
 549                (emit-branch src 'br-if-not L1))))
 550            (else
 551             (comp-push test)
 552             (emit-branch src 'br-if-not L1)))
 553
 554          (comp-tail then)
 555          ;; if there is an RA, comp-tail will cause a jump to it -- just
 556          ;; have to clean up here if there is no RA.
 557          (if (and (not RA) (not (eq? context 'tail)))
 558              (emit-branch #f 'br L2))
 559          (emit-label L1)
 560          (comp-tail alternate)
 561          (if (and (not RA) (not (eq? context 'tail)))
 562              (emit-label L2))))
 563
 564       ((<primitive-ref> src name)
 565        (cond
 566         ((eq? (module-variable (fluid-ref *comp-module*) name)
 567               (module-variable the-root-module name))
 568          (case context
 569            ((tail push vals)
 570             (emit-code src (make-glil-toplevel 'ref name))))
 571          (maybe-emit-return))
 572         ((module-variable the-root-module name)
 573          (case context
 574            ((tail push vals)
 575             (emit-code src (make-glil-module 'ref '(guile) name #f))))
 576          (maybe-emit-return))
 577         (else
 578          (case context
 579            ((tail push vals)
 580             (emit-code src (make-glil-module
 581                             'ref (module-name (fluid-ref *comp-module*)) name #f))))
 582          (maybe-emit-return))))
 583
 584       ((<lexical-ref> src gensym)
 585        (case context
 586          ((push vals tail)
 587           (pmatch (hashq-ref (hashq-ref allocation gensym) self)
 588             ((,local? ,boxed? . ,index)
 589              (emit-code src (make-glil-lexical local? boxed? 'ref index)))
 590             (,loc
 591              (error "badness" x loc)))))
 592        (maybe-emit-return))
 593
 594       ((<lexical-set> src gensym exp)
 595        (comp-push exp)
 596        (pmatch (hashq-ref (hashq-ref allocation gensym) self)
 597          ((,local? ,boxed? . ,index)
 598           (emit-code src (make-glil-lexical local? boxed? 'set index)))
 599          (,loc
 600           (error "badness" x loc)))
 601        (case context
 602          ((tail push vals)
 603           (emit-code #f (make-glil-void))))
 604        (maybe-emit-return))
 605
 606       ((<module-ref> src mod name public?)
 607        (emit-code src (make-glil-module 'ref mod name public?))
 608        (case context
 609          ((drop) (emit-code #f (make-glil-call 'drop 1))))
 610        (maybe-emit-return))
 611
 612       ((<module-set> src mod name public? exp)
 613        (comp-push exp)
 614        (emit-code src (make-glil-module 'set mod name public?))
 615        (case context
 616          ((tail push vals)
 617           (emit-code #f (make-glil-void))))
 618        (maybe-emit-return))
 619
 620       ((<toplevel-ref> src name)
 621        (emit-code src (make-glil-toplevel 'ref name))
 622        (case context
 623          ((drop) (emit-code #f (make-glil-call 'drop 1))))
 624        (maybe-emit-return))
 625
 626       ((<toplevel-set> src name exp)
 627        (comp-push exp)
 628        (emit-code src (make-glil-toplevel 'set name))
 629        (case context
 630          ((tail push vals)
 631           (emit-code #f (make-glil-void))))
 632        (maybe-emit-return))
 633
 634       ((<toplevel-define> src name exp)
 635        (comp-push exp)
 636        (emit-code src (make-glil-toplevel 'define name))
 637        (case context
 638          ((tail push vals)
 639           (emit-code #f (make-glil-void))))
 640        (maybe-emit-return))
 641
 642       ((<lambda>)
 643        (let ((free-locs (cdr (hashq-ref allocation x))))
 644          (case context
 645            ((push vals tail)
 646             (emit-code #f (flatten-lambda x #f allocation))
 647             (if (not (null? free-locs))
 648                 (begin
 649                   (for-each
 650                    (lambda (loc)
 651                      (pmatch loc
 652                        ((,local? ,boxed? . ,n)
 653                         (emit-code #f (make-glil-lexical local? #f 'ref n)))
 654                        (else (error "what" x loc))))
 655                    free-locs)
 656                   (emit-code #f (make-glil-call 'vector (length free-locs)))
 657                   (emit-code #f (make-glil-call 'make-closure 2)))))))
 658        (maybe-emit-return))
 659
 660       ((<lambda-case> src req opt rest kw inits vars else body)
 661        ;; o/~ feature on top of feature o/~
 662        ;; req := (name ...)
 663        ;; opt := (name ...) | #f
 664        ;; rest := name | #f
 665        ;; kw: (allow-other-keys? (keyword name var) ...) | #f
 666        ;; vars: (sym ...)
 667        ;; init: tree-il in context of vars
 668        ;; vars map to named arguments in the following order:
 669        ;;  required, optional (positional), rest, keyword.
 670        (let* ((nreq (length req))
 671               (nopt (if opt (length opt) 0))
 672               (rest-idx (and rest (+ nreq nopt)))
 673               (opt-names (or opt '()))
 674               (allow-other-keys? (if kw (car kw) #f))
 675               (kw-indices (map (lambda (x)
 676                                  (pmatch x
 677                                    ((,key ,name ,var)
 678                                     (cons key (list-index vars var)))
 679                                    (else (error "bad kwarg" x))))
 680                                (if kw (cdr kw) '())))
 681               (nargs (apply max (+ nreq nopt (if rest 1 0))
 682                             (map 1+ (map cdr kw-indices))))
 683               (nlocs (cdr (hashq-ref allocation x)))
 684               (else-label (and else (make-label))))
 685          (or (= nargs
 686                 (length vars)
 687                 (+ nreq (length inits) (if rest 1 0)))
 688              (error "something went wrong"
 689                     req opt rest kw inits vars nreq nopt kw-indices nargs))
 690          ;; the prelude, to check args & reset the stack pointer,
 691          ;; allowing room for locals
 692          (emit-code
 693           src
 694           (cond
 695            (kw
 696             (make-glil-kw-prelude nreq nopt rest-idx kw-indices
 697                                   allow-other-keys? nlocs else-label))
 698            ((or rest opt)
 699             (make-glil-opt-prelude nreq nopt rest-idx nlocs else-label))
 700            (#t
 701             (make-glil-std-prelude nreq nlocs else-label))))
 702          ;; box args if necessary
 703          (for-each
 704           (lambda (v)
 705             (pmatch (hashq-ref (hashq-ref allocation v) self)
 706               ((#t #t . ,n)
 707                (emit-code #f (make-glil-lexical #t #f 'ref n))
 708                (emit-code #f (make-glil-lexical #t #t 'box n)))))
 709           vars)
 710          ;; write bindings info
 711          (if (not (null? vars))
 712              (emit-bindings
 713               #f
 714               (let lp ((kw (if kw (cdr kw) '()))
 715                        (names (append (reverse opt-names) (reverse req)))
 716                        (vars (list-tail vars (+ nreq nopt
 717                                                 (if rest 1 0)))))
 718                 (pmatch kw
 719                   (()
 720                    ;; fixme: check that vars is empty
 721                    (reverse (if rest (cons rest names) names)))
 722                   (((,key ,name ,var) . ,kw)
 723                    (if (memq var vars)
 724                        (lp kw (cons name names) (delq var vars))
 725                        (lp kw names vars)))
 726                   (,kw (error "bad keywords, yo" kw))))
 727               vars allocation self emit-code))
 728          ;; init optional/kw args
 729          (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq)))
 730            (cond
 731             ((null? inits))             ; done
 732             ((and rest-idx (= n rest-idx))
 733              (lp inits (1+ n) (cdr vars)))
 734             (#t
 735              (pmatch (hashq-ref (hashq-ref allocation (car vars)) self)
 736                ((#t ,boxed? . ,n*) (guard (= n* n))
 737                 (let ((L (make-label)))
 738                   (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
 739                   (emit-code #f (make-glil-branch 'br-if L))
 740                   (comp-push (car inits))
 741                   (emit-code #f (make-glil-lexical #t boxed? 'set n))
 742                   (emit-label L)
 743                   (lp (cdr inits) (1+ n) (cdr vars))))
 744                (#t (error "what" inits))))))
 745          ;; post-prelude case label for label calls
 746          (emit-label (car (hashq-ref allocation x)))
 747          (comp-tail body)
 748          (if (not (null? vars))
 749              (emit-code #f (make-glil-unbind)))
 750          (if else-label
 751              (begin
 752                (emit-label else-label)
 753                (comp-tail else)))))
 754
 755       ((<let> src names vars vals body)
 756        (for-each comp-push vals)
 757        (emit-bindings src names vars allocation self emit-code)
 758        (for-each (lambda (v)
 759                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 760                      ((#t #f . ,n)
 761                       (emit-code src (make-glil-lexical #t #f 'set n)))
 762                      ((#t #t . ,n)
 763                       (emit-code src (make-glil-lexical #t #t 'box n)))
 764                      (,loc (error "badness" x loc))))
 765                  (reverse vars))
 766        (comp-tail body)
 767        (emit-code #f (make-glil-unbind)))
 768
 769       ((<letrec> src names vars vals body)
 770        (for-each (lambda (v)
 771                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 772                      ((#t #t . ,n)
 773                       (emit-code src (make-glil-lexical #t #t 'empty-box n)))
 774                      (,loc (error "badness" x loc))))
 775                  vars)
 776        (for-each comp-push vals)
 777        (emit-bindings src names vars allocation self emit-code)
 778        (for-each (lambda (v)
 779                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 780                      ((#t #t . ,n)
 781                       (emit-code src (make-glil-lexical #t #t 'set n)))
 782                      (,loc (error "badness" x loc))))
 783                  (reverse vars))
 784        (comp-tail body)
 785        (emit-code #f (make-glil-unbind)))
 786
 787       ((<fix> src names vars vals body)
 788        ;; The ideal here is to just render the lambda bodies inline, and
 789        ;; wire the code together with gotos. We can do that if
 790        ;; analyze-lexicals has determined that a given var has "label"
 791        ;; allocation -- which is the case if it is in `fix-labels'.
 792        ;;
 793        ;; But even for closures that we can't inline, we can do some
 794        ;; tricks to avoid heap-allocation for the binding itself. Since
 795        ;; we know the vals are lambdas, we can set them to their local
 796        ;; var slots first, then capture their bindings, mutating them in
 797        ;; place.
 798        (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
 799          (for-each
 800           (lambda (x v)
 801             (cond
 802              ((hashq-ref allocation x)
 803               ;; allocating a closure
 804               (emit-code #f (flatten-lambda x v allocation))
 805               (if (not (null? (cdr (hashq-ref allocation x))))
 806                   ;; Need to make-closure first, but with a temporary #f
 807                   ;; free-variables vector, so we are mutating fresh
 808                   ;; closures on the heap.
 809                   (begin
 810                     (emit-code #f (make-glil-const #f))
 811                     (emit-code #f (make-glil-call 'make-closure 2))))
 812               (pmatch (hashq-ref (hashq-ref allocation v) self)
 813                 ((#t #f . ,n)
 814                  (emit-code src (make-glil-lexical #t #f 'set n)))
 815                 (,loc (error "badness" x loc))))
 816              (else
 817               ;; labels allocation: emit label & body, but jump over it
 818               (let ((POST (make-label)))
 819                 (emit-branch #f 'br POST)
 820                 (let lp ((lcase (lambda-body x)))
 821                   (if lcase
 822                       (record-case lcase
 823                         ((<lambda-case> src req vars body else)
 824                          (emit-label (car (hashq-ref allocation lcase)))
 825                          ;; FIXME: opt & kw args in the bindings
 826                          (emit-bindings #f req vars allocation self emit-code)
 827                          (if src
 828                              (emit-code #f (make-glil-source src)))
 829                          (comp-fix body (or RA new-RA))
 830                          (emit-code #f (make-glil-unbind))
 831                          (lp else)))
 832                       (emit-label POST)))))))
 833           vals
 834           vars)
 835          ;; Emit bindings metadata for closures
 836          (let ((binds (let lp ((out '()) (vars vars) (names names))
 837                         (cond ((null? vars) (reverse! out))
 838                               ((assq (car vars) fix-labels)
 839                                (lp out (cdr vars) (cdr names)))
 840                               (else
 841                                (lp (acons (car vars) (car names) out)
 842                                    (cdr vars) (cdr names)))))))
 843            (emit-bindings src (map cdr binds) (map car binds)
 844                           allocation self emit-code))
 845          ;; Now go back and fix up the bindings for closures.
 846          (for-each
 847           (lambda (x v)
 848             (let ((free-locs (if (hashq-ref allocation x)
 849                                  (cdr (hashq-ref allocation x))
 850                                  ;; can hit this latter case for labels allocation
 851                                  '())))
 852               (if (not (null? free-locs))
 853                   (begin
 854                     (for-each
 855                      (lambda (loc)
 856                        (pmatch loc
 857                          ((,local? ,boxed? . ,n)
 858                           (emit-code #f (make-glil-lexical local? #f 'ref n)))
 859                          (else (error "what" x loc))))
 860                      free-locs)
 861                     (emit-code #f (make-glil-call 'vector (length free-locs)))
 862                     (pmatch (hashq-ref (hashq-ref allocation v) self)
 863                       ((#t #f . ,n)
 864                        (emit-code #f (make-glil-lexical #t #f 'fix n)))
 865                       (,loc (error "badness" x loc)))))))
 866           vals
 867           vars)
 868          (comp-tail body)
 869          (if new-RA
 870              (emit-label new-RA))
 871          (emit-code #f (make-glil-unbind))))
 872
 873       ((<let-values> src exp body)
 874        (record-case body
 875          ((<lambda-case> req opt kw rest vars body else)
 876           (if (or opt kw else)
 877               (error "unexpected lambda-case in let-values" x))
 878           (let ((MV (make-label)))
 879             (comp-vals exp MV)
 880             (emit-code #f (make-glil-const 1))
 881             (emit-label MV)
 882             (emit-code src (make-glil-mv-bind
 883                             (vars->bind-list
 884                              (append req (if rest (list rest) '()))
 885                              vars allocation self)
 886                             (and rest #t)))
 887             (for-each (lambda (v)
 888                         (pmatch (hashq-ref (hashq-ref allocation v) self)
 889                           ((#t #f . ,n)
 890                            (emit-code src (make-glil-lexical #t #f 'set n)))
 891                           ((#t #t . ,n)
 892                            (emit-code src (make-glil-lexical #t #t 'box n)))
 893                           (,loc (error "badness" x loc))))
 894                       (reverse vars))
 895             (comp-tail body)
 896             (emit-code #f (make-glil-unbind)))))))))