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