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

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