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

   1 ;;; TREE-IL -> GLIL compiler
   2
   3 ;; Copyright (C) 2001,2008,2009,2010 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     (unused-toplevel     . ,unused-toplevel-analysis)
  49     (unbound-variable    . ,unbound-variable-analysis)
  50     (arity-mismatch      . ,arity-analysis)))
  51
  52 (define (compile-glil x e opts)
  53   (define warnings
  54     (or (and=> (memq #:warnings opts) cadr)
  55         '()))
  56
  57   ;; Go through the warning passes.
  58   (let ((analyses (filter-map (lambda (kind)
  59                                 (assoc-ref %warning-passes kind))
  60                               warnings)))
  61     (analyze-tree analyses x e))
  62
  63   (let* ((x (make-lambda (tree-il-src x) '()
  64                          (make-lambda-case #f '() #f #f #f '() '() x #f)))
  65          (x (optimize! x e opts))
  66          (allocation (analyze-lexicals x)))
  67
  68     (with-fluid* *comp-module* e
  69       (lambda ()
  70         (values (flatten-lambda x #f allocation)
  71                 e
  72                 e)))))
  73
  74 \f
  75
  76 (define *primcall-ops* (make-hash-table))
  77 (for-each
  78  (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
  79  '(((eq? . 2) . eq?)
  80    ((eqv? . 2) . eqv?)
  81    ((equal? . 2) . equal?)
  82    ((= . 2) . ee?)
  83    ((< . 2) . lt?)
  84    ((> . 2) . gt?)
  85    ((<= . 2) . le?)
  86    ((>= . 2) . ge?)
  87    ((+ . 2) . add)
  88    ((- . 2) . sub)
  89    ((1+ . 1) . add1)
  90    ((1- . 1) . sub1)
  91    ((* . 2) . mul)
  92    ((/ . 2) . div)
  93    ((quotient . 2) . quo)
  94    ((remainder . 2) . rem)
  95    ((modulo . 2) . mod)
  96    ((ash . 2) . ash)
  97    ((logand . 2) . logand)
  98    ((logior . 2) . logior)
  99    ((logxor . 2) . logxor)
 100    ((not . 1) . not)
 101    ((pair? . 1) . pair?)
 102    ((cons . 2) . cons)
 103    ((car . 1) . car)
 104    ((cdr . 1) . cdr)
 105    ((set-car! . 2) . set-car!)
 106    ((set-cdr! . 2) . set-cdr!)
 107    ((null? . 1) . null?)
 108    ((list? . 1) . list?)
 109    (list . list)
 110    (vector . vector)
 111    ((class-of . 1) . class-of)
 112    ((@slot-ref . 2) . slot-ref)
 113    ((@slot-set! . 3) . slot-set)
 114    ((vector-ref . 2) . vector-ref)
 115    ((vector-set! . 3) . vector-set)
 116    ((variable-ref . 1) . variable-ref)
 117    ;; nb, *not* variable-set! -- the args are switched
 118    ((variable-set . 2) . variable-set)
 119    ((variable-bound? . 1) . variable-bound?)
 120    ((struct? . 1) . struct?)
 121    ((struct-vtable . 1) . struct-vtable)
 122    ((struct-ref . 2) . struct-ref)
 123    ((struct-set! . 3) . struct-set)
 124    (make-struct . make-struct)
 125
 126    ;; hack for javascript
 127    ((return . 1) return)
 128
 129    ((bytevector-u8-ref . 2) . bv-u8-ref)
 130    ((bytevector-u8-set! . 3) . bv-u8-set)
 131    ((bytevector-s8-ref . 2) . bv-s8-ref)
 132    ((bytevector-s8-set! . 3) . bv-s8-set)
 133
 134    ((bytevector-u16-ref . 3) . bv-u16-ref)
 135    ((bytevector-u16-set! . 4) . bv-u16-set)
 136    ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
 137    ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
 138    ((bytevector-s16-ref . 3) . bv-s16-ref)
 139    ((bytevector-s16-set! . 4) . bv-s16-set)
 140    ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
 141    ((bytevector-s16-native-set! . 3) . bv-s16-native-set)
 142
 143    ((bytevector-u32-ref . 3) . bv-u32-ref)
 144    ((bytevector-u32-set! . 4) . bv-u32-set)
 145    ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
 146    ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
 147    ((bytevector-s32-ref . 3) . bv-s32-ref)
 148    ((bytevector-s32-set! . 4) . bv-s32-set)
 149    ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
 150    ((bytevector-s32-native-set! . 3) . bv-s32-native-set)
 151
 152    ((bytevector-u64-ref . 3) . bv-u64-ref)
 153    ((bytevector-u64-set! . 4) . bv-u64-set)
 154    ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
 155    ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
 156    ((bytevector-s64-ref . 3) . bv-s64-ref)
 157    ((bytevector-s64-set! . 4) . bv-s64-set)
 158    ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
 159    ((bytevector-s64-native-set! . 3) . bv-s64-native-set)
 160
 161    ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
 162    ((bytevector-ieee-single-set! . 4) . bv-f32-set)
 163    ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
 164    ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
 165    ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
 166    ((bytevector-ieee-double-set! . 4) . bv-f64-set)
 167    ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
 168    ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))
 169
 170
 171 \f
 172
 173 (define (make-label) (gensym ":L"))
 174
 175 (define (vars->bind-list ids vars allocation proc)
 176   (map (lambda (id v)
 177          (pmatch (hashq-ref (hashq-ref allocation v) proc)
 178            ((#t ,boxed? . ,n)
 179             (list id boxed? n))
 180            (,x (error "badness" id v x))))
 181        ids
 182        vars))
 183
 184 (define (emit-bindings src ids vars allocation proc emit-code)
 185   (emit-code src (make-glil-bind
 186                   (vars->bind-list ids vars allocation proc))))
 187
 188 (define (with-output-to-code proc)
 189   (let ((out '()))
 190     (define (emit-code src x)
 191       (set! out (cons x out))
 192       (if src
 193           (set! out (cons (make-glil-source src) out))))
 194     (proc emit-code)
 195     (reverse out)))
 196
 197 (define (flatten-lambda x self-label allocation)
 198   (record-case x
 199     ((<lambda> src meta body)
 200      (make-glil-program
 201       meta
 202       (with-output-to-code
 203        (lambda (emit-code)
 204          ;; write source info for proc
 205          (if src (emit-code #f (make-glil-source src)))
 206          ;; emit pre-prelude label for self tail calls in which the
 207          ;; number of arguments doesn't check out at compile time
 208          (if self-label
 209              (emit-code #f (make-glil-label self-label)))
 210          ;; compile the body, yo
 211          (flatten body allocation x self-label (car (hashq-ref allocation x))
 212                   emit-code)))))))
 213
 214 (define (flatten x allocation self self-label fix-labels emit-code)
 215   (define (emit-label label)
 216     (emit-code #f (make-glil-label label)))
 217   (define (emit-branch src inst label)
 218     (emit-code src (make-glil-branch inst label)))
 219
 220   ;; RA: "return address"; #f unless we're in a non-tail fix with labels
 221   ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
 222   (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
 223     (define (comp-tail tree) (comp tree context RA MVRA))
 224     (define (comp-push tree) (comp tree 'push #f #f))
 225     (define (comp-drop tree) (comp tree 'drop #f #f))
 226     (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
 227     (define (comp-fix tree RA) (comp tree context RA MVRA))
 228
 229     ;; A couple of helpers. Note that if we are in tail context, we
 230     ;; won't have an RA.
 231     (define (maybe-emit-return)
 232       (if RA
 233           (emit-branch #f 'br RA)
 234           (if (eq? context 'tail)
 235               (emit-code #f (make-glil-call 'return 1)))))
 236
 237     (record-case x
 238       ((<void>)
 239        (case context
 240          ((push vals tail)
 241           (emit-code #f (make-glil-void))))
 242        (maybe-emit-return))
 243
 244       ((<const> src exp)
 245        (case context
 246          ((push vals tail)
 247           (emit-code src (make-glil-const exp))))
 248        (maybe-emit-return))
 249
 250       ;; FIXME: should represent sequence as exps tail
 251       ((<sequence> exps)
 252        (let lp ((exps exps))
 253          (if (null? (cdr exps))
 254              (comp-tail (car exps))
 255              (begin
 256                (comp-drop (car exps))
 257                (lp (cdr exps))))))
 258
 259       ((<application> src proc args)
 260        ;; FIXME: need a better pattern-matcher here
 261        (cond
 262         ((and (primitive-ref? proc)
 263               (eq? (primitive-ref-name proc) '@apply)
 264               (>= (length args) 1))
 265          (let ((proc (car args))
 266                (args (cdr args)))
 267            (cond
 268             ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 269                   (not (eq? context 'push)) (not (eq? context 'vals)))
 270              ;; tail: (lambda () (apply values '(1 2)))
 271              ;; drop: (lambda () (apply values '(1 2)) 3)
 272              ;; push: (lambda () (list (apply values '(10 12)) 1))
 273              (case context
 274                ((drop) (for-each comp-drop args) (maybe-emit-return))
 275                ((tail)
 276                 (for-each comp-push args)
 277                 (emit-code src (make-glil-call 'return/values* (length args))))))
 278
 279             (else
 280              (case context
 281                ((tail)
 282                 (comp-push proc)
 283                 (for-each comp-push args)
 284                 (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
 285                ((push)
 286                 (emit-code src (make-glil-call 'new-frame 0))
 287                 (comp-push proc)
 288                 (for-each comp-push args)
 289                 (emit-code src (make-glil-call 'apply (1+ (length args))))
 290                 (maybe-emit-return))
 291                ((vals)
 292                 (comp-vals
 293                  (make-application src (make-primitive-ref #f 'apply)
 294                                    (cons proc args))
 295                  MVRA)
 296                 (maybe-emit-return))
 297                ((drop)
 298                 ;; Well, shit. The proc might return any number of
 299                 ;; values (including 0), since it's in a drop context,
 300                 ;; yet apply does not create a MV continuation. So we
 301                 ;; mv-call out to our trampoline instead.
 302                 (comp-drop
 303                  (make-application src (make-primitive-ref #f 'apply)
 304                                    (cons proc args)))
 305                 (maybe-emit-return)))))))
 306
 307         ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
 308               (not (eq? context 'push)))
 309          ;; tail: (lambda () (values '(1 2)))
 310          ;; drop: (lambda () (values '(1 2)) 3)
 311          ;; push: (lambda () (list (values '(10 12)) 1))
 312          ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
 313          (case context
 314            ((drop) (for-each comp-drop args) (maybe-emit-return))
 315            ((vals)
 316             (for-each comp-push args)
 317             (emit-code #f (make-glil-const (length args)))
 318             (emit-branch src 'br MVRA))
 319            ((tail)
 320             (for-each comp-push args)
 321             (emit-code src (make-glil-call 'return/values (length args))))))
 322
 323         ((and (primitive-ref? proc)
 324               (eq? (primitive-ref-name proc) '@call-with-values)
 325               (= (length args) 2))
 326          ;; CONSUMER
 327          ;; PRODUCER
 328          ;; (mv-call MV)
 329          ;; ([tail]-call 1)
 330          ;; goto POST
 331          ;; MV: [tail-]call/nargs
 332          ;; POST: (maybe-drop)
 333          (case context
 334            ((vals)
 335             ;; Fall back.
 336             (comp-vals
 337              (make-application src (make-primitive-ref #f 'call-with-values)
 338                                args)
 339              MVRA)
 340             (maybe-emit-return))
 341            (else
 342             (let ((MV (make-label)) (POST (make-label))
 343                   (producer (car args)) (consumer (cadr args)))
 344               (if (not (eq? context 'tail))
 345                   (emit-code src (make-glil-call 'new-frame 0)))
 346               (comp-push consumer)
 347               (emit-code src (make-glil-call 'new-frame 0))
 348               (comp-push producer)
 349               (emit-code src (make-glil-mv-call 0 MV))
 350               (case context
 351                 ((tail) (emit-code src (make-glil-call 'tail-call 1)))
 352                 (else   (emit-code src (make-glil-call 'call 1))
 353                         (emit-branch #f 'br POST)))
 354               (emit-label MV)
 355               (case context
 356                 ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
 357                 (else   (emit-code src (make-glil-call 'call/nargs 0))
 358                         (emit-label POST)
 359                         (if (eq? context 'drop)
 360                             (emit-code #f (make-glil-call 'drop 1)))
 361                         (maybe-emit-return)))))))
 362
 363         ((and (primitive-ref? proc)
 364               (eq? (primitive-ref-name proc) '@call-with-current-continuation)
 365               (= (length args) 1))
 366          (case context
 367            ((tail)
 368             (comp-push (car args))
 369             (emit-code src (make-glil-call 'tail-call/cc 1)))
 370            ((vals)
 371             (comp-vals
 372              (make-application
 373               src (make-primitive-ref #f 'call-with-current-continuation)
 374               args)
 375              MVRA)
 376             (maybe-emit-return))
 377            ((push)
 378             (comp-push (car args))
 379             (emit-code src (make-glil-call 'call/cc 1))
 380             (maybe-emit-return))
 381            ((drop)
 382             ;; Crap. Just like `apply' in drop context.
 383             (comp-drop
 384              (make-application
 385               src (make-primitive-ref #f 'call-with-current-continuation)
 386               args))
 387             (maybe-emit-return))))
 388
 389         ((and (primitive-ref? proc)
 390               (or (hash-ref *primcall-ops*
 391                             (cons (primitive-ref-name proc) (length args)))
 392                   (hash-ref *primcall-ops* (primitive-ref-name proc))))
 393          => (lambda (op)
 394               (for-each comp-push args)
 395               (emit-code src (make-glil-call op (length args)))
 396               (case (instruction-pushes op)
 397                 ((0)
 398                  (case context
 399                    ((tail push vals) (emit-code #f (make-glil-void))))
 400                  (maybe-emit-return))
 401                 ((1)
 402                  (case context
 403                    ((drop) (emit-code #f (make-glil-call 'drop 1))))
 404                  (maybe-emit-return))
 405                 (else
 406                  (error "bad primitive op: too many pushes"
 407                         op (instruction-pushes op))))))
 408
 409         ;; self-call in tail position
 410         ((and (lexical-ref? proc)
 411               self-label (eq? (lexical-ref-gensym proc) self-label)
 412               (eq? context 'tail))
 413          ;; first, evaluate new values, pushing them on the stack
 414          (for-each comp-push args)
 415          (let lp ((lcase (lambda-body self)))
 416            (cond
 417             ((and (lambda-case? lcase)
 418                   (not (lambda-case-kw lcase))
 419                   (not (lambda-case-opt lcase))
 420                   (not (lambda-case-rest lcase))
 421                   (= (length args) (length (lambda-case-req lcase))))
 422              ;; we have a case that matches the args; rename variables
 423              ;; and goto the case label
 424              (for-each (lambda (sym)
 425                          (pmatch (hashq-ref (hashq-ref allocation sym) self)
 426                            ((#t #f . ,index) ; unboxed
 427                             (emit-code #f (make-glil-lexical #t #f 'set index)))
 428                            ((#t #t . ,index) ; boxed
 429                             ;; new box
 430                             (emit-code #f (make-glil-lexical #t #t 'box index)))
 431                            (,x (error "what" x))))
 432                        (reverse (lambda-case-vars lcase)))
 433              (emit-branch src 'br (car (hashq-ref allocation lcase))))
 434             ((lambda-case? lcase)
 435              ;; no match, try next case
 436              (lp (lambda-case-alternate lcase)))
 437             (else
 438              ;; no cases left; shuffle args down and jump before the prelude.
 439              (for-each (lambda (i)
 440                          (emit-code #f (make-glil-lexical #t #f 'set i)))
 441                        (reverse (iota (length args))))
 442              (emit-branch src 'br self-label)))))
 443
 444         ;; lambda, the ultimate goto
 445         ((and (lexical-ref? proc)
 446               (assq (lexical-ref-gensym proc) fix-labels))
 447          ;; like the self-tail-call case, though we can handle "drop"
 448          ;; contexts too. first, evaluate new values, pushing them on
 449          ;; the stack
 450          (for-each comp-push args)
 451          ;; find the specific case, rename args, and goto the case label
 452          (let lp ((lcase (lambda-body
 453                           (assq-ref fix-labels (lexical-ref-gensym proc)))))
 454            (cond
 455             ((and (lambda-case? lcase)
 456                   (not (lambda-case-kw lcase))
 457                   (not (lambda-case-opt lcase))
 458                   (not (lambda-case-rest lcase))
 459                   (= (length args) (length (lambda-case-req lcase))))
 460              ;; we have a case that matches the args; rename variables
 461              ;; and goto the case label
 462              (for-each (lambda (sym)
 463                          (pmatch (hashq-ref (hashq-ref allocation sym) self)
 464                            ((#t #f . ,index) ; unboxed
 465                             (emit-code #f (make-glil-lexical #t #f 'set index)))
 466                            ((#t #t . ,index) ; boxed
 467                             (emit-code #f (make-glil-lexical #t #t 'box index)))
 468                            (,x (error "what" x))))
 469                        (reverse (lambda-case-vars lcase)))
 470              (emit-branch src 'br (car (hashq-ref allocation lcase))))
 471             ((lambda-case? lcase)
 472              ;; no match, try next case
 473              (lp (lambda-case-alternate lcase)))
 474             (else
 475              ;; no cases left. we can't really handle this currently.
 476              ;; ideally we would push on a new frame, then do a "local
 477              ;; call" -- which doesn't require consing up a program
 478              ;; object. but for now error, as this sort of case should
 479              ;; preclude label allocation.
 480              (error "couldn't find matching case for label call" x)))))
 481
 482         (else
 483          (if (not (eq? context 'tail))
 484              (emit-code src (make-glil-call 'new-frame 0)))
 485          (comp-push proc)
 486          (for-each comp-push args)
 487          (let ((len (length args)))
 488            (case context
 489              ((tail) (emit-code src (make-glil-call 'tail-call len)))
 490              ((push) (emit-code src (make-glil-call 'call len))
 491                      (maybe-emit-return))
 492              ((vals) (emit-code src (make-glil-mv-call len MVRA))
 493                      (maybe-emit-return))
 494              ((drop) (let ((MV (make-label)) (POST (make-label)))
 495                        (emit-code src (make-glil-mv-call len MV))
 496                        (emit-code #f (make-glil-call 'drop 1))
 497                        (emit-branch #f 'br (or RA POST))
 498                        (emit-label MV)
 499                        (emit-code #f (make-glil-mv-bind '() #f))
 500                        (emit-code #f (make-glil-unbind))
 501                        (if RA
 502                            (emit-branch #f 'br RA)
 503                            (emit-label POST)))))))))
 504
 505       ((<conditional> src test consequent alternate)
 506        ;;     TEST
 507        ;;     (br-if-not L1)
 508        ;;     consequent
 509        ;;     (br L2)
 510        ;; L1: alternate
 511        ;; L2:
 512        (let ((L1 (make-label)) (L2 (make-label)))
 513          ;; need a pattern matcher
 514          (record-case test
 515            ((<application> proc args)
 516             (record-case proc
 517               ((<primitive-ref> name)
 518                (let ((len (length args)))
 519                  (cond
 520
 521                   ((and (eq? name 'eq?) (= len 2))
 522                    (comp-push (car args))
 523                    (comp-push (cadr args))
 524                    (emit-branch src 'br-if-not-eq L1))
 525
 526                   ((and (eq? name 'null?) (= len 1))
 527                    (comp-push (car args))
 528                    (emit-branch src 'br-if-not-null L1))
 529
 530                   ((and (eq? name 'not) (= len 1))
 531                    (let ((app (car args)))
 532                      (record-case app
 533                        ((<application> proc args)
 534                         (let ((len (length args)))
 535                           (record-case proc
 536                             ((<primitive-ref> name)
 537                              (cond
 538
 539                               ((and (eq? name 'eq?) (= len 2))
 540                                (comp-push (car args))
 541                                (comp-push (cadr args))
 542                                (emit-branch src 'br-if-eq L1))
 543
 544                               ((and (eq? name 'null?) (= len 1))
 545                                (comp-push (car args))
 546                                (emit-branch src 'br-if-null L1))
 547
 548                               (else
 549                                (comp-push app)
 550                                (emit-branch src 'br-if L1))))
 551                             (else
 552                              (comp-push app)
 553                              (emit-branch src 'br-if L1)))))
 554                        (else
 555                         (comp-push app)
 556                         (emit-branch src 'br-if L1)))))
 557
 558                   (else
 559                    (comp-push test)
 560                    (emit-branch src 'br-if-not L1)))))
 561               (else
 562                (comp-push test)
 563                (emit-branch src 'br-if-not L1))))
 564            (else
 565             (comp-push test)
 566             (emit-branch src 'br-if-not L1)))
 567
 568          (comp-tail consequent)
 569          ;; if there is an RA, comp-tail will cause a jump to it -- just
 570          ;; have to clean up here if there is no RA.
 571          (if (and (not RA) (not (eq? context 'tail)))
 572              (emit-branch #f 'br L2))
 573          (emit-label L1)
 574          (comp-tail alternate)
 575          (if (and (not RA) (not (eq? context 'tail)))
 576              (emit-label L2))))
 577
 578       ((<primitive-ref> src name)
 579        (cond
 580         ((eq? (module-variable (fluid-ref *comp-module*) name)
 581               (module-variable the-root-module name))
 582          (case context
 583            ((tail push vals)
 584             (emit-code src (make-glil-toplevel 'ref name))))
 585          (maybe-emit-return))
 586         ((module-variable the-root-module name)
 587          (case context
 588            ((tail push vals)
 589             (emit-code src (make-glil-module 'ref '(guile) name #f))))
 590          (maybe-emit-return))
 591         (else
 592          (case context
 593            ((tail push vals)
 594             (emit-code src (make-glil-module
 595                             'ref (module-name (fluid-ref *comp-module*)) name #f))))
 596          (maybe-emit-return))))
 597
 598       ((<lexical-ref> src gensym)
 599        (case context
 600          ((push vals tail)
 601           (pmatch (hashq-ref (hashq-ref allocation gensym) self)
 602             ((,local? ,boxed? . ,index)
 603              (emit-code src (make-glil-lexical local? boxed? 'ref index)))
 604             (,loc
 605              (error "badness" x loc)))))
 606        (maybe-emit-return))
 607
 608       ((<lexical-set> src gensym exp)
 609        (comp-push exp)
 610        (pmatch (hashq-ref (hashq-ref allocation gensym) self)
 611          ((,local? ,boxed? . ,index)
 612           (emit-code src (make-glil-lexical local? boxed? 'set index)))
 613          (,loc
 614           (error "badness" x loc)))
 615        (case context
 616          ((tail push vals)
 617           (emit-code #f (make-glil-void))))
 618        (maybe-emit-return))
 619
 620       ((<module-ref> src mod name public?)
 621        (emit-code src (make-glil-module 'ref mod name public?))
 622        (case context
 623          ((drop) (emit-code #f (make-glil-call 'drop 1))))
 624        (maybe-emit-return))
 625
 626       ((<module-set> src mod name public? exp)
 627        (comp-push exp)
 628        (emit-code src (make-glil-module 'set mod name public?))
 629        (case context
 630          ((tail push vals)
 631           (emit-code #f (make-glil-void))))
 632        (maybe-emit-return))
 633
 634       ((<toplevel-ref> src name)
 635        (emit-code src (make-glil-toplevel 'ref name))
 636        (case context
 637          ((drop) (emit-code #f (make-glil-call 'drop 1))))
 638        (maybe-emit-return))
 639
 640       ((<toplevel-set> src name exp)
 641        (comp-push exp)
 642        (emit-code src (make-glil-toplevel 'set name))
 643        (case context
 644          ((tail push vals)
 645           (emit-code #f (make-glil-void))))
 646        (maybe-emit-return))
 647
 648       ((<toplevel-define> src name exp)
 649        (comp-push exp)
 650        (emit-code src (make-glil-toplevel 'define name))
 651        (case context
 652          ((tail push vals)
 653           (emit-code #f (make-glil-void))))
 654        (maybe-emit-return))
 655
 656       ((<lambda>)
 657        (let ((free-locs (cdr (hashq-ref allocation x))))
 658          (case context
 659            ((push vals tail)
 660             (emit-code #f (flatten-lambda x #f allocation))
 661             (if (not (null? free-locs))
 662                 (begin
 663                   (for-each
 664                    (lambda (loc)
 665                      (pmatch loc
 666                        ((,local? ,boxed? . ,n)
 667                         (emit-code #f (make-glil-lexical local? #f 'ref n)))
 668                        (else (error "what" x loc))))
 669                    free-locs)
 670                   (emit-code #f (make-glil-call 'make-closure
 671                                                 (length free-locs))))))))
 672        (maybe-emit-return))
 673
 674       ((<lambda-case> src req opt rest kw inits vars alternate body)
 675        ;; o/~ feature on top of feature o/~
 676        ;; req := (name ...)
 677        ;; opt := (name ...) | #f
 678        ;; rest := name | #f
 679        ;; kw: (allow-other-keys? (keyword name var) ...) | #f
 680        ;; vars: (sym ...)
 681        ;; init: tree-il in context of vars
 682        ;; vars map to named arguments in the following order:
 683        ;;  required, optional (positional), rest, keyword.
 684        (let* ((nreq (length req))
 685               (nopt (if opt (length opt) 0))
 686               (rest-idx (and rest (+ nreq nopt)))
 687               (opt-names (or opt '()))
 688               (allow-other-keys? (if kw (car kw) #f))
 689               (kw-indices (map (lambda (x)
 690                                  (pmatch x
 691                                    ((,key ,name ,var)
 692                                     (cons key (list-index vars var)))
 693                                    (else (error "bad kwarg" x))))
 694                                (if kw (cdr kw) '())))
 695               (nargs (apply max (+ nreq nopt (if rest 1 0))
 696                             (map 1+ (map cdr kw-indices))))
 697               (nlocs (cdr (hashq-ref allocation x)))
 698               (alternate-label (and alternate (make-label))))
 699          (or (= nargs
 700                 (length vars)
 701                 (+ nreq (length inits) (if rest 1 0)))
 702              (error "something went wrong"
 703                     req opt rest kw inits vars nreq nopt kw-indices nargs))
 704          ;; the prelude, to check args & reset the stack pointer,
 705          ;; allowing room for locals
 706          (emit-code
 707           src
 708           (cond
 709            (kw
 710             (make-glil-kw-prelude nreq nopt rest-idx kw-indices
 711                                   allow-other-keys? nlocs alternate-label))
 712            ((or rest opt)
 713             (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label))
 714            (#t
 715             (make-glil-std-prelude nreq nlocs alternate-label))))
 716          ;; box args if necessary
 717          (for-each
 718           (lambda (v)
 719             (pmatch (hashq-ref (hashq-ref allocation v) self)
 720               ((#t #t . ,n)
 721                (emit-code #f (make-glil-lexical #t #f 'ref n))
 722                (emit-code #f (make-glil-lexical #t #t 'box n)))))
 723           vars)
 724          ;; write bindings info
 725          (if (not (null? vars))
 726              (emit-bindings
 727               #f
 728               (let lp ((kw (if kw (cdr kw) '()))
 729                        (names (append (reverse opt-names) (reverse req)))
 730                        (vars (list-tail vars (+ nreq nopt
 731                                                 (if rest 1 0)))))
 732                 (pmatch kw
 733                   (()
 734                    ;; fixme: check that vars is empty
 735                    (reverse (if rest (cons rest names) names)))
 736                   (((,key ,name ,var) . ,kw)
 737                    (if (memq var vars)
 738                        (lp kw (cons name names) (delq var vars))
 739                        (lp kw names vars)))
 740                   (,kw (error "bad keywords, yo" kw))))
 741               vars allocation self emit-code))
 742          ;; init optional/kw args
 743          (let lp ((inits inits) (n nreq) (vars (list-tail vars nreq)))
 744            (cond
 745             ((null? inits))             ; done
 746             ((and rest-idx (= n rest-idx))
 747              (lp inits (1+ n) (cdr vars)))
 748             (#t
 749              (pmatch (hashq-ref (hashq-ref allocation (car vars)) self)
 750                ((#t ,boxed? . ,n*) (guard (= n* n))
 751                 (let ((L (make-label)))
 752                   (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
 753                   (emit-code #f (make-glil-branch 'br-if L))
 754                   (comp-push (car inits))
 755                   (emit-code #f (make-glil-lexical #t boxed? 'set n))
 756                   (emit-label L)
 757                   (lp (cdr inits) (1+ n) (cdr vars))))
 758                (#t (error "what" inits))))))
 759          ;; post-prelude case label for label calls
 760          (emit-label (car (hashq-ref allocation x)))
 761          (comp-tail body)
 762          (if (not (null? vars))
 763              (emit-code #f (make-glil-unbind)))
 764          (if alternate-label
 765              (begin
 766                (emit-label alternate-label)
 767                (comp-tail alternate)))))
 768
 769       ((<let> src names vars vals body)
 770        (for-each comp-push vals)
 771        (emit-bindings src names vars allocation self emit-code)
 772        (for-each (lambda (v)
 773                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 774                      ((#t #f . ,n)
 775                       (emit-code src (make-glil-lexical #t #f 'set n)))
 776                      ((#t #t . ,n)
 777                       (emit-code src (make-glil-lexical #t #t 'box n)))
 778                      (,loc (error "badness" x loc))))
 779                  (reverse vars))
 780        (comp-tail body)
 781        (emit-code #f (make-glil-unbind)))
 782
 783       ((<letrec> src names vars vals body)
 784        (for-each (lambda (v)
 785                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 786                      ((#t #t . ,n)
 787                       (emit-code src (make-glil-lexical #t #t 'empty-box n)))
 788                      (,loc (error "badness" x loc))))
 789                  vars)
 790        (for-each comp-push vals)
 791        (emit-bindings src names vars allocation self emit-code)
 792        (for-each (lambda (v)
 793                    (pmatch (hashq-ref (hashq-ref allocation v) self)
 794                      ((#t #t . ,n)
 795                       (emit-code src (make-glil-lexical #t #t 'set n)))
 796                      (,loc (error "badness" x loc))))
 797                  (reverse vars))
 798        (comp-tail body)
 799        (emit-code #f (make-glil-unbind)))
 800
 801       ((<fix> src names vars vals body)
 802        ;; The ideal here is to just render the lambda bodies inline, and
 803        ;; wire the code together with gotos. We can do that if
 804        ;; analyze-lexicals has determined that a given var has "label"
 805        ;; allocation -- which is the case if it is in `fix-labels'.
 806        ;;
 807        ;; But even for closures that we can't inline, we can do some
 808        ;; tricks to avoid heap-allocation for the binding itself. Since
 809        ;; we know the vals are lambdas, we can set them to their local
 810        ;; var slots first, then capture their bindings, mutating them in
 811        ;; place.
 812        (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
 813          (for-each
 814           (lambda (x v)
 815             (cond
 816              ((hashq-ref allocation x)
 817               ;; allocating a closure
 818               (emit-code #f (flatten-lambda x v allocation))
 819               (let ((free-locs (cdr (hashq-ref allocation x))))
 820                 (if (not (null? free-locs))
 821                     ;; Need to make-closure first, so we have a fresh closure on
 822                     ;; the heap, but with a temporary free values.
 823                     (begin
 824                       (for-each (lambda (loc)
 825                                   (emit-code #f (make-glil-const #f)))
 826                                 free-locs)
 827                       (emit-code #f (make-glil-call 'make-closure
 828                                                     (length free-locs))))))
 829               (pmatch (hashq-ref (hashq-ref allocation v) self)
 830                 ((#t #f . ,n)
 831                  (emit-code src (make-glil-lexical #t #f 'set n)))
 832                 (,loc (error "badness" x loc))))
 833              (else
 834               ;; labels allocation: emit label & body, but jump over it
 835               (let ((POST (make-label)))
 836                 (emit-branch #f 'br POST)
 837                 (let lp ((lcase (lambda-body x)))
 838                   (if lcase
 839                       (record-case lcase
 840                         ((<lambda-case> src req vars body alternate)
 841                          (emit-label (car (hashq-ref allocation lcase)))
 842                          ;; FIXME: opt & kw args in the bindings
 843                          (emit-bindings #f req vars allocation self emit-code)
 844                          (if src
 845                              (emit-code #f (make-glil-source src)))
 846                          (comp-fix body (or RA new-RA))
 847                          (emit-code #f (make-glil-unbind))
 848                          (lp alternate)))
 849                       (emit-label POST)))))))
 850           vals
 851           vars)
 852          ;; Emit bindings metadata for closures
 853          (let ((binds (let lp ((out '()) (vars vars) (names names))
 854                         (cond ((null? vars) (reverse! out))
 855                               ((assq (car vars) fix-labels)
 856                                (lp out (cdr vars) (cdr names)))
 857                               (else
 858                                (lp (acons (car vars) (car names) out)
 859                                    (cdr vars) (cdr names)))))))
 860            (emit-bindings src (map cdr binds) (map car binds)
 861                           allocation self emit-code))
 862          ;; Now go back and fix up the bindings for closures.
 863          (for-each
 864           (lambda (x v)
 865             (let ((free-locs (if (hashq-ref allocation x)
 866                                  (cdr (hashq-ref allocation x))
 867                                  ;; can hit this latter case for labels allocation
 868                                  '())))
 869               (if (not (null? free-locs))
 870                   (begin
 871                     (for-each
 872                      (lambda (loc)
 873                        (pmatch loc
 874                          ((,local? ,boxed? . ,n)
 875                           (emit-code #f (make-glil-lexical local? #f 'ref n)))
 876                          (else (error "what" x loc))))
 877                      free-locs)
 878                     (pmatch (hashq-ref (hashq-ref allocation v) self)
 879                       ((#t #f . ,n)
 880                        (emit-code #f (make-glil-lexical #t #f 'fix n)))
 881                       (,loc (error "badness" x loc)))))))
 882           vals
 883           vars)
 884          (comp-tail body)
 885          (if new-RA
 886              (emit-label new-RA))
 887          (emit-code #f (make-glil-unbind))))
 888
 889       ((<let-values> src exp body)
 890        (record-case body
 891          ((<lambda-case> req opt kw rest vars body alternate)
 892           (if (or opt kw alternate)
 893               (error "unexpected lambda-case in let-values" x))
 894           (let ((MV (make-label)))
 895             (comp-vals exp MV)
 896             (emit-code #f (make-glil-const 1))
 897             (emit-label MV)
 898             (emit-code src (make-glil-mv-bind
 899                             (vars->bind-list
 900                              (append req (if rest (list rest) '()))
 901                              vars allocation self)
 902                             (and rest #t)))
 903             (for-each (lambda (v)
 904                         (pmatch (hashq-ref (hashq-ref allocation v) self)
 905                           ((#t #f . ,n)
 906                            (emit-code src (make-glil-lexical #t #f 'set n)))
 907                           ((#t #t . ,n)
 908                            (emit-code src (make-glil-lexical #t #t 'box n)))
 909                           (,loc (error "badness" x loc))))
 910                       (reverse vars))
 911             (comp-tail body)
 912             (emit-code #f (make-glil-unbind))))))
 913
 914       ;; much trickier than i thought this would be, at first, due to the need
 915       ;; to have body's return value(s) on the stack while the unwinder runs,
 916       ;; then proceed with returning or dropping or what-have-you, interacting
 917       ;; with RA and MVRA. What have you, I say.
 918       ((<dynwind> src body winder unwinder)
 919        (comp-push winder)
 920        (comp-push unwinder)
 921        (comp-drop (make-application src winder '()))
 922        (emit-code #f (make-glil-call 'wind 2))
 923
 924        (case context
 925          ((tail)
 926           (let ((MV (make-label)))
 927             (comp-vals body MV)
 928             ;; one value: unwind...
 929             (emit-code #f (make-glil-call 'unwind 0))
 930             (comp-drop (make-application src unwinder '()))
 931             ;; ...and return the val
 932             (emit-code #f (make-glil-call 'return 1))
 933
 934             (emit-label MV)
 935             ;; multiple values: unwind...
 936             (emit-code #f (make-glil-call 'unwind 0))
 937             (comp-drop (make-application src unwinder '()))
 938             ;; and return the values.
 939             (emit-code #f (make-glil-call 'return/nvalues 1))))
 940
 941          ((push)
 942           ;; we only want one value. so ask for one value
 943           (comp-push body)
 944           ;; and unwind, leaving the val on the stack
 945           (emit-code #f (make-glil-call 'unwind 0))
 946           (comp-drop (make-application src unwinder '())))
 947
 948          ((vals)
 949           (let ((MV (make-label)))
 950             (comp-vals body MV)
 951             ;; one value: push 1 and fall through to MV case
 952             (emit-code #f (make-glil-const 1))
 953
 954             (emit-label MV)
 955             ;; multiple values: unwind...
 956             (emit-code #f (make-glil-call 'unwind 0))
 957             (comp-drop (make-application src unwinder '()))
 958             ;; and goto the MVRA.
 959             (emit-branch #f 'br MVRA)))
 960
 961          ((drop)
 962           ;; compile body, discarding values. then unwind...
 963           (comp-drop body)
 964           (emit-code #f (make-glil-call 'unwind 0))
 965           (comp-drop (make-application src unwinder '()))
 966           ;; and fall through, or goto RA if there is one.
 967           (if RA
 968               (emit-branch #f 'br RA)))))
 969
 970       ((<dynlet> src fluids vals body)
 971        (for-each comp-push fluids)
 972        (for-each comp-push vals)
 973        (emit-code #f (make-glil-call 'wind-fluids (length fluids)))
 974
 975        (case context
 976          ((tail)
 977           (let ((MV (make-label)))
 978             ;; NB: in tail case, it is possible to preserve asymptotic tail
 979             ;; recursion, via merging unwind-fluids structures -- but we'd need
 980             ;; to compile in the body twice (once in tail context, assuming the
 981             ;; caller unwinds, and once with this trampoline thing, unwinding
 982             ;; ourselves).
 983             (comp-vals body MV)
 984             ;; one value: unwind and return
 985             (emit-code #f (make-glil-call 'unwind-fluids 0))
 986             (emit-code #f (make-glil-call 'return 1))
 987
 988             (emit-label MV)
 989             ;; multiple values: unwind and return values
 990             (emit-code #f (make-glil-call 'unwind-fluids 0))
 991             (emit-code #f (make-glil-call 'return/nvalues 1))))
 992
 993          ((push)
 994           (comp-push body)
 995           (emit-code #f (make-glil-call 'unwind-fluids 0)))
 996
 997          ((vals)
 998           (let ((MV (make-label)))
 999             (comp-vals body MV)
1000             ;; one value: push 1 and fall through to MV case
1001             (emit-code #f (make-glil-const 1))
1002
1003             (emit-label MV)
1004             ;; multiple values: unwind and goto MVRA
1005             (emit-code #f (make-glil-call 'unwind-fluids 0))
1006             (emit-branch #f 'br MVRA)))
1007
1008          ((drop)
1009           ;; compile body, discarding values. then unwind...
1010           (comp-drop body)
1011           (emit-code #f (make-glil-call 'unwind-fluids 0))
1012           ;; and fall through, or goto RA if there is one.
1013           (if RA
1014               (emit-branch #f 'br RA)))))
1015
1016       ;; What's the deal here? The deal is that we are compiling the start of a
1017       ;; delimited continuation. We try to avoid heap allocation in the normal
1018       ;; case; so the body is an expression, not a thunk, and we try to render
1019       ;; the handler inline. Also we did some analysis, in analyze.scm, so that
1020       ;; if the continuation isn't referenced, we don't reify it. This makes it
1021       ;; possible to implement catch and throw with delimited continuations,
1022       ;; without any overhead.
1023       ((<prompt> src tag body handler pre-unwind-handler)
1024        (let ((H (make-label))
1025              (POST (make-label))
1026              (inline? (lambda-case? handler))
1027              (escape-only? (hashq-ref allocation x)))
1028          ;; First, set up the prompt.
1029          (comp-push tag)
1030          (if inline?
1031              (emit-code #f (make-glil-const #f)) ;; push #f as handler
1032              (comp-push handler))
1033          (if pre-unwind-handler
1034              (comp-push pre-unwind-handler)
1035              (emit-code #f (make-glil-const #f)))
1036          (emit-code src (make-glil-prompt H inline? escape-only?))
1037
1038          ;; Then we compile the body, with its normal return path, unwinding
1039          ;; before proceeding.
1040          (case context
1041            ((tail)
1042             (let ((MV (make-label)))
1043               (comp-vals body MV)
1044               ;; one value: unwind and return
1045               (emit-code #f (make-glil-call 'unwind 0))
1046               (emit-code #f (make-glil-call 'return 1))
1047               ;; multiple values: unwind and return
1048               (emit-label MV)
1049               (emit-code #f (make-glil-call 'unwind 0))
1050               (emit-code #f (make-glil-call 'return/nvalues 1))))
1051
1052            ((push)
1053             ;; we only want one value. so ask for one value, unwind, and jump to
1054             ;; post
1055             (comp-push body)
1056             (emit-code #f (make-glil-call 'unwind 0))
1057             (emit-branch #f 'br POST))
1058
1059            ((vals)
1060             (let ((MV (make-label)))
1061               (comp-vals body MV)
1062               ;; one value: push 1 and fall through to MV case
1063               (emit-code #f (make-glil-const 1))
1064               ;; multiple values: unwind and goto MVRA
1065               (emit-label MV)
1066               (emit-code #f (make-glil-call 'unwind 0))
1067               (emit-branch #f 'br MVRA)))
1068
1069            ((drop)
1070             ;; compile body, discarding values, then unwind & fall through.
1071             (comp-drop body)
1072             (emit-code #f (make-glil-call 'unwind 0))
1073             (emit-branch #f 'br (or RA POST))))
1074
1075          ;; Now the handler.
1076          (emit-label H)
1077          (cond
1078           (inline?
1079            ;; The inlined handler. The stack is now made up of the continuation,
1080            ;; and then the args to the continuation (pushed separately), and
1081            ;; then the number of args, including the continuation.
1082            (record-case handler
1083              ((<lambda-case> req opt kw rest vars body alternate)
1084               (if (or opt kw alternate)
1085                   (error "unexpected lambda-case in prompt" x))
1086               (emit-code src (make-glil-mv-bind
1087                               (vars->bind-list
1088                                (append req (if rest (list rest) '()))
1089                                vars allocation self)
1090                               (and rest #t)))
1091               (for-each (lambda (v)
1092                           (pmatch (hashq-ref (hashq-ref allocation v) self)
1093                             ((#t #f . ,n)
1094                              (emit-code src (make-glil-lexical #t #f 'set n)))
1095                             ((#t #t . ,n)
1096                              (emit-code src (make-glil-lexical #t #t 'box n)))
1097                             (,loc (error "badness" x loc))))
1098                         (reverse vars))
1099               (comp-tail body)
1100               (emit-code #f (make-glil-unbind)))))
1101           (else
1102            ;; The handler was on the heap, so here we're just processing its
1103            ;; return values.
1104            (case context
1105              ((tail)
1106               (emit-code #f (make-glil-call 'return/nvalues 1)))
1107              ((push)
1108               ;; truncate to one value, leave on stack
1109               (emit-code #f (make-glil-mv-bind '(handler-ret) #f))
1110               (emit-code #f (make-glil-unbind)))
1111              ((vals)
1112               (emit-branch #f 'br MVRA))
1113              ((drop)
1114               ;; truncate to 0 vals
1115               (emit-code #f (make-glil-mv-bind '() #f))
1116               (emit-code #f (make-glil-unbind))
1117               (if RA (emit-branch #f 'br RA))))))
1118
1119          ;; The POST label, if necessary.
1120          (if (or (eq? context 'push)
1121                  (and (eq? context 'drop) (not RA)))
1122              (emit-label POST))))
1123
1124       ((<control> src tag type args)
1125        (comp-push tag)
1126        (case type
1127          ((throw)
1128           (for-each comp-push args)
1129           (emit-code src (make-glil-call 'throw (length args))))
1130          (else (error "bad control type" x)))))))