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

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