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

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