code:
;;; TREE-IL -> GLIL compiler

;; Copyright (C) 2001,2008,2009,2010 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language tree-il analyze)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (ice-9 vlist)
  #:use-module (system base syntax)
  #:use-module (system base message)
  #:use-module (system vm program)
  #:use-module (language tree-il)
  #:use-module (system base pmatch)
  #:export (analyze-lexicals
            analyze-tree
            unused-variable-analysis
            unused-toplevel-analysis
            unbound-variable-analysis
            arity-analysis))

;; Allocation is the process of assigning storage locations for lexical
;; variables. A lexical variable has a distinct "address", or storage
;; location, for each procedure in which it is referenced.
;;
;; A variable is "local", i.e., allocated on the stack, if it is
;; referenced from within the procedure that defined it. Otherwise it is
;; a "closure" variable. For example:
;;
;;    (lambda (a) a) ; a will be local
;; `a' is local to the procedure.
;;
;;    (lambda (a) (lambda () a))
;; `a' is local to the outer procedure, but a closure variable with
;; respect to the inner procedure.
;;
;; If a variable is ever assigned, it needs to be heap-allocated
;; ("boxed"). This is so that closures and continuations capture the
;; variable's identity, not just one of the values it may have over the
;; course of program execution. If the variable is never assigned, there
;; is no distinction between value and identity, so closing over its
;; identity (whether through closures or continuations) can make a copy
;; of its value instead.
;;
;; Local variables are stored on the stack within a procedure's call
;; frame. Their index into the stack is determined from their linear
;; postion within a procedure's binding path:
;; (let (0 1)
;;   (let (2 3) ...)
;;   (let (2) ...))
;;   (let (2 3 4) ...))
;; etc.
;;
;; This algorithm has the problem that variables are only allocated
;; indices at the end of the binding path. If variables bound early in
;; the path are not used in later portions of the path, their indices
;; will not be recycled. This problem is particularly egregious in the
;; expansion of `or':
;;
;;  (or x y z)
;;    -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
;;
;; As you can see, the `a' binding is only used in the ephemeral
;; `consequent' clause of the first `if', but its index would be
;; reserved for the whole of the `or' expansion. So we have a hack for
;; this specific case. A proper solution would be some sort of liveness
;; analysis, and not our linear allocation algorithm.
;;
;; Closure variables are captured when a closure is created, and stored in a
;; vector inline to the closure object itself. Each closure variable has a
;; unique index into that vector.
;;
;; There is one more complication. Procedures bound by <fix> may, in
;; some cases, be rendered inline to their parent procedure. That is to
;; say,
;;
;;  (letrec ((lp (lambda () (lp)))) (lp))
;;    => (fix ((lp (lambda () (lp)))) (lp))
;;      => goto FIX-BODY; LP: goto LP; FIX-BODY: goto LP;
;;         ^ jump over the loop  ^ the fixpoint lp ^ starting off the loop
;;
;; The upshot is that we don't have to allocate any space for the `lp'
;; closure at all, as it can be rendered inline as a loop. So there is
;; another kind of allocation, "label allocation", in which the
;; procedure is simply a label, placed at the start of the lambda body.
;; The label is the gensym under which the lambda expression is bound.
;;
;; The analyzer checks to see that the label is called with the correct
;; number of arguments. Calls to labels compile to rename + goto.
;; Lambda, the ultimate goto!
;;
;;
;; The return value of `analyze-lexicals' is a hash table, the
;; "allocation".
;;
;; The allocation maps gensyms -- recall that each lexically bound
;; variable has a unique gensym -- to storage locations ("addresses").
;; Since one gensym may have many storage locations, if it is referenced
;; in many procedures, it is a two-level map.
;;
;; The allocation also stored information on how many local variables
;; need to be allocated for each procedure, lexicals that have been
;; translated into labels, and information on what free variables to
;; capture from its lexical parent procedure.
;;
;; In addition, we have a conflation: while we're traversing the code,
;; recording information to pass to the compiler, we take the
;; opportunity to generate labels for each lambda-case clause, so that
;; generated code can skip argument checks at runtime if they match at
;; compile-time.
;;
;; Also, while we're a-traversing and an-allocating, we check prompt
;; handlers to see if the "continuation" argument is used. If not, we
;; mark the prompt as being "escape-only". This allows us to implement
;; `catch' and `throw' using `prompt' and `control', but without causing
;; a continuation to be reified. Heh heh.
;;
;; That is:
;;
;;  sym -> {lambda -> address}
;;  lambda -> (labels . free-locs)
;;  lambda-case -> (gensym . nlocs)
;;  prompt -> escape-only?
;;
;; address ::= (local? boxed? . index)
;; labels ::= ((sym . lambda) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.

(define (make-hashq k v)
  (let ((res (make-hash-table)))
    (hashq-set! res k v)
    res))

(define (analyze-lexicals x)
  ;; bound-vars: lambda -> (sym ...)
  ;;  all identifiers bound within a lambda
  (define bound-vars (make-hash-table))
  ;; free-vars: lambda -> (sym ...)
  ;;  all identifiers referenced in a lambda, but not bound
  ;;  NB, this includes identifiers referenced by contained lambdas
  (define free-vars (make-hash-table))
  ;; assigned: sym -> #t
  ;;  variables that are assigned
  (define assigned (make-hash-table))
  ;; refcounts: sym -> count
  ;;  allows us to detect the or-expansion in O(1) time
  (define refcounts (make-hash-table))
  ;; labels: sym -> lambda
  ;;  for determining if fixed-point procedures can be rendered as
  ;;  labels.
  (define labels (make-hash-table))

  ;; returns variables referenced in expr
  (define (analyze! x proc labels-in-proc tail? tail-call-args)
    (define (step y) (analyze! y proc labels-in-proc #f #f))
    (define (step-tail y) (analyze! y proc labels-in-proc tail? #f))
    (define (step-tail-call y args) (analyze! y proc labels-in-proc #f
                                              (and tail? args)))
    (define (recur/labels x new-proc labels)
      (analyze! x new-proc (append labels labels-in-proc) #t #f))
    (define (recur x new-proc) (analyze! x new-proc '() tail? #f))
    (record-case x
      ((<application> proc args)
       (apply lset-union eq? (step-tail-call proc args)
              (map step args)))

      ((<conditional> test consequent alternate)
       (lset-union eq? (step test) (step-tail consequent) (step-tail alternate)))

      ((<lexical-ref> gensym)
       (hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
       (if (not (and tail-call-args
                     (memq gensym labels-in-proc)
                     (let ((p (hashq-ref labels gensym)))
                       (and p
                            (let lp ((c (lambda-body p)))
                              (and c (lambda-case? c)
                                   (or
                                    ;; for now prohibit optional &
                                    ;; keyword arguments; can relax this
                                    ;; restriction later
                                    (and (= (length (lambda-case-req c))
                                            (length tail-call-args))
                                         (not (lambda-case-opt c))
                                         (not (lambda-case-kw c))
                                         (not (lambda-case-rest c)))
                                    (lp (lambda-case-alternate c)))))))))
           (hashq-set! labels gensym #f))
       (list gensym))

      ((<lexical-set> gensym exp)
       (hashq-set! assigned gensym #t)
       (hashq-set! labels gensym #f)
       (lset-adjoin eq? (step exp) gensym))

      ((<module-set> exp)
       (step exp))

      ((<toplevel-set> exp)
       (step exp))

      ((<toplevel-define> exp)
       (step exp))

      ((<sequence> exps)
       (let lp ((exps exps) (ret '()))
         (cond ((null? exps) '())
               ((null? (cdr exps))
                (lset-union eq? ret (step-tail (car exps))))
               (else
                (lp (cdr exps) (lset-union eq? ret (step (car exps))))))))

      ((<lambda> body)
       ;; order is important here
       (hashq-set! bound-vars x '())
       (let ((free (recur body x)))
         (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
         (hashq-set! free-vars x free)
         free))

      ((<lambda-case> opt kw inits gensyms body alternate)
       (hashq-set! bound-vars proc
                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
       (lset-union
        eq?
        (lset-difference eq?
                         (lset-union eq?
                                     (apply lset-union eq? (map step inits))
                                     (step-tail body))
                         gensyms)
        (if alternate (step-tail alternate) '())))

      ((<let> gensyms vals body)
       (hashq-set! bound-vars proc
                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
       (lset-difference eq?
                        (apply lset-union eq? (step-tail body) (map step vals))
                        gensyms))

      ((<letrec> gensyms vals body)
       (hashq-set! bound-vars proc
                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
       (for-each (lambda (sym) (hashq-set! assigned sym #t)) gensyms)
       (lset-difference eq?
                        (apply lset-union eq? (step-tail body) (map step vals))
                        gensyms))

      ((<fix> gensyms vals body)
       ;; Try to allocate these procedures as labels.
       (for-each (lambda (sym val) (hashq-set! labels sym val))
                 gensyms vals)
       (hashq-set! bound-vars proc
                   (append (reverse gensyms) (hashq-ref bound-vars proc)))
       ;; Step into subexpressions.
       (let* ((var-refs
               (map
                ;; Since we're trying to label-allocate the lambda,
                ;; pretend it's not a closure, and just recurse into its
                ;; body directly. (Otherwise, recursing on a closure
                ;; that references one of the fix's bound vars would
                ;; prevent label allocation.)
                (lambda (x)
                  (record-case x
                    ((<lambda> body)
                     ;; just like the closure case, except here we use
                     ;; recur/labels instead of recur
                     (hashq-set! bound-vars x '())
                     (let ((free (recur/labels body x gensyms)))
                       (hashq-set! bound-vars x (reverse! (hashq-ref bound-vars x)))
                       (hashq-set! free-vars x free)
                       free))))
                vals))
              (vars-with-refs (map cons gensyms var-refs))
              (body-refs (recur/labels body proc gensyms)))
         (define (delabel-dependents! sym)
           (let ((refs (assq-ref vars-with-refs sym)))
             (if refs
                 (for-each (lambda (sym)
                             (if (hashq-ref labels sym)
                                 (begin
                                   (hashq-set! labels sym #f)
                                   (delabel-dependents! sym))))
                           refs))))
         ;; Stepping into the lambdas and the body might have made some
         ;; procedures not label-allocatable -- which might have
         ;; knock-on effects. For example:
         ;;   (fix ((a (lambda () (b)))
         ;;         (b (lambda () a)))
         ;;     (a))
         ;; As far as `a' is concerned, both `a' and `b' are
         ;; label-allocatable. But `b' references `a' not in a proc-tail
         ;; position, which makes `a' not label-allocatable. The
         ;; knock-on effect is that, when back-propagating this
         ;; information to `a', `b' will also become not
         ;; label-allocatable, as it is referenced within `a', which is
         ;; allocated as a closure. This is a transitive relationship.
         (for-each (lambda (sym)
                     (if (not (hashq-ref labels sym))
                         (delabel-dependents! sym)))
                   gensyms)
         ;; Now lift bound variables with label-allocated lambdas to the
         ;; parent procedure.
         (for-each
          (lambda (sym val)
            (if (hashq-ref labels sym)
                ;; Remove traces of the label-bound lambda. The free
                ;; vars will propagate up via the return val.
                (begin
                  (hashq-set! bound-vars proc
                              (append (hashq-ref bound-vars val)
                                      (hashq-ref bound-vars proc)))
                  (hashq-remove! bound-vars val)
                  (hashq-remove! free-vars val))))
          gensyms vals)
         (lset-difference eq?
                          (apply lset-union eq? body-refs var-refs)
                          gensyms)))

      ((<let-values> exp body)
       (lset-union eq? (step exp) (step body)))

      ((<dynwind> body winder unwinder)
       (lset-union eq? (step body) (step winder) (step unwinder)))

      ((<dynlet> fluids vals body)
       (apply lset-union eq? (step body) (map step (append fluids vals))))

      ((<dynref> fluid)
       (step fluid))

      ((<dynset> fluid exp)
       (lset-union eq? (step fluid) (step exp)))

      ((<prompt> tag body handler)
       (lset-union eq? (step tag) (step body) (step-tail handler)))

      ((<abort> tag args tail)
       (apply lset-union eq? (step tag) (step tail) (map step args)))

      (else '())))

  ;; allocation: sym -> {lambda -> address}
  ;;             lambda -> (nlocs labels . free-locs)
  (define allocation (make-hash-table))

  (define (allocate! x proc n)
    (define (recur y) (allocate! y proc n))
    (record-case x
      ((<application> proc args)
       (apply max (recur proc) (map recur args)))

      ((<conditional> test consequent alternate)
       (max (recur test) (recur consequent) (recur alternate)))

      ((<lexical-set> exp)
       (recur exp))

      ((<module-set> exp)
       (recur exp))

      ((<toplevel-set> exp)
       (recur exp))

      ((<toplevel-define> exp)
       (recur exp))

      ((<sequence> exps)
       (apply max (map recur exps)))

      ((<lambda> body)
       ;; allocate closure vars in order
       (let lp ((c (hashq-ref free-vars x)) (n 0))
         (if (pair? c)
             (begin
               (hashq-set! (hashq-ref allocation (car c))
                           x
                           `(#f ,(hashq-ref assigned (car c)) . ,n))
               (lp (cdr c) (1+ n)))))

       (let ((nlocs (allocate! body x 0))
             (free-addresses
              (map (lambda (v)
                     (hashq-ref (hashq-ref allocation v) proc))
                   (hashq-ref free-vars x)))
             (labels (filter cdr
                             (map (lambda (sym)
                                    (cons sym (hashq-ref labels sym)))
                                  (hashq-ref bound-vars x)))))
         ;; set procedure allocations
         (hashq-set! allocation x (cons labels free-addresses)))
       n)

      ((<lambda-case> opt kw inits gensyms body alternate)
       (max
        (let lp ((gensyms gensyms) (n n))
          (if (null? gensyms)
              (let ((nlocs (apply
                            max
                            (allocate! body proc n)
                            ;; inits not logically at the end, but they
                            ;; are the list...
                            (map (lambda (x) (allocate! x proc n)) inits))))
                ;; label and nlocs for the case
                (hashq-set! allocation x (cons (gensym ":LCASE") nlocs))
                nlocs)
              (begin
                (hashq-set! allocation (car gensyms)
                            (make-hashq
                             proc `(#t ,(hashq-ref assigned (car gensyms)) . ,n)))
                (lp (cdr gensyms) (1+ n)))))
        (if alternate (allocate! alternate proc n) n)))

      ((<let> gensyms vals body)
       (let ((nmax (apply max (map recur vals))))
         (cond
          ;; the `or' hack
          ((and (conditional? body)
                (= (length gensyms) 1)
                (let ((v (car gensyms)))
                  (and (not (hashq-ref assigned v))
                       (= (hashq-ref refcounts v 0) 2)
                       (lexical-ref? (conditional-test body))
                       (eq? (lexical-ref-gensym (conditional-test body)) v)
                       (lexical-ref? (conditional-consequent body))
                       (eq? (lexical-ref-gensym (conditional-consequent body)) v))))
           (hashq-set! allocation (car gensyms)
                       (make-hashq proc `(#t #f . ,n)))
           ;; the 1+ for this var
           (max nmax (1+ n) (allocate! (conditional-alternate body) proc n)))
          (else
           (let lp ((gensyms gensyms) (n n))
             (if (null? gensyms)
                 (max nmax (allocate! body proc n))
                 (let ((v (car gensyms)))
                   (hashq-set!
                    allocation v
                    (make-hashq proc
                                `(#t ,(hashq-ref assigned v) . ,n)))
                   (lp (cdr gensyms) (1+ n)))))))))

      ((<letrec> gensyms vals body)
       (let lp ((gensyms gensyms) (n n))
         (if (null? gensyms)
             (let ((nmax (apply max
                                (map (lambda (x)
                                       (allocate! x proc n))
                                     vals))))
               (max nmax (allocate! body proc n)))
             (let ((v (car gensyms)))
               (hashq-set!
                allocation v
                (make-hashq proc
                            `(#t ,(hashq-ref assigned v) . ,n)))
               (lp (cdr gensyms) (1+ n))))))

      ((<fix> gensyms vals body)
       (let lp ((in gensyms) (n n))
         (if (null? in)
             (let lp ((gensyms gensyms) (vals vals) (nmax n))
               (cond
                ((null? gensyms)
                 (max nmax (allocate! body proc n)))
                ((hashq-ref labels (car gensyms))
                 ;; allocate lambda body inline to proc
                 (lp (cdr gensyms)
                     (cdr vals)
                     (record-case (car vals)
                       ((<lambda> body)
                        (max nmax (allocate! body proc n))))))
                (else
                 ;; allocate closure
                 (lp (cdr gensyms)
                     (cdr vals)
                     (max nmax (allocate! (car vals) proc n))))))

             (let ((v (car in)))
               (cond
                ((hashq-ref assigned v)
                 (error "fixpoint procedures may not be assigned" x))
                ((hashq-ref labels v)
                 ;; no binding, it's a label
                 (lp (cdr in) n))
                (else
                 ;; allocate closure binding
                 (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
                 (lp (cdr in) (1+ n))))))))

      ((<let-values> exp body)
       (max (recur exp) (recur body)))

      ((<dynwind> body winder unwinder)
       (max (recur body) (recur winder) (recur unwinder)))

      ((<dynlet> fluids vals body)
       (apply max (recur body) (map recur (append fluids vals))))

      ((<dynref> fluid)
       (recur fluid))

      ((<dynset> fluid exp)
       (max (recur fluid) (recur exp)))

      ((<prompt> tag body handler)
       (let ((cont-var (and (lambda-case? handler)
                            (pair? (lambda-case-gensyms handler))
                            (car (lambda-case-gensyms handler)))))
         (hashq-set! allocation x
                     (and cont-var (zero? (hashq-ref refcounts cont-var 0))))
         (max (recur tag) (recur body) (recur handler))))

      ((<abort> tag args tail)
       (apply max (recur tag) (recur tail) (map recur args)))

      (else n)))

  (analyze! x #f '() #t #f)
  (allocate! x #f 0)

  allocation)

;;;
;;; Tree analyses for warnings.
;;;

(define-record-type <tree-analysis>
  (make-tree-analysis leaf down up post init)
  tree-analysis?
  (leaf tree-analysis-leaf)  ;; (lambda (x result env locs) ...)
  (down tree-analysis-down)  ;; (lambda (x result env locs) ...)
  (up   tree-analysis-up)    ;; (lambda (x result env locs) ...)
  (post tree-analysis-post)  ;; (lambda (result env) ...)
  (init tree-analysis-init)) ;; arbitrary value

(define (analyze-tree analyses tree env)
  "Run all tree analyses listed in ANALYSES on TREE for ENV, using
`tree-il-fold'.  Return TREE.  The leaf/down/up procedures of each analysis are
passed a ``location stack', which is the stack of `tree-il-src' values for each
parent tree (a list); it can be used to approximate source location when
accurate information is missing from a given `tree-il' element."

  (define (traverse proc update-locs)
    ;; Return a tree traversing procedure that returns a list of analysis
    ;; results prepended by the location stack.
    (lambda (x results)
      (let ((locs (update-locs x (car results))))
        (cons locs ;; the location stack
              (map (lambda (analysis result)
                     ((proc analysis) x result env locs))
                   analyses
                   (cdr results))))))

  ;; Keeping/extending/shrinking the location stack.
  (define (keep-locs x locs)   locs)
  (define (extend-locs x locs) (cons (tree-il-src x) locs))
  (define (shrink-locs x locs) (cdr locs))

  (let ((results
         (tree-il-fold (traverse tree-analysis-leaf keep-locs)
                       (traverse tree-analysis-down extend-locs)
                       (traverse tree-analysis-up   shrink-locs)
                       (cons '() ;; empty location stack
                             (map tree-analysis-init analyses))
                       tree)))

    (for-each (lambda (analysis result)
                ((tree-analysis-post analysis) result env))
              analyses
              (cdr results)))

  tree)

;;;
;;; Unused variable analysis.
;;;

;; <binding-info> records are used during tree traversals in
;; `unused-variable-analysis'.  They contain a list of the local vars
;; currently in scope, and a list of locals vars that have been referenced.
(define-record-type <binding-info>
  (make-binding-info vars refs)
  binding-info?
  (vars binding-info-vars)  ;; ((GENSYM NAME LOCATION) ...)
  (refs binding-info-refs)) ;; (GENSYM ...)

(define unused-variable-analysis
  ;; Report unused variables in the given tree.
  (make-tree-analysis
   (lambda (x info env locs)
     ;; X is a leaf: extend INFO's refs accordingly.
     (let ((refs (binding-info-refs info))
           (vars (binding-info-vars info)))
       (record-case x
         ((<lexical-ref> gensym)
          (make-binding-info vars (vhash-consq gensym #t refs)))
         (else info))))

   (lambda (x info env locs)
     ;; Going down into X: extend INFO's variable list
     ;; accordingly.
     (let ((refs (binding-info-refs info))
           (vars (binding-info-vars info))
           (src  (tree-il-src x)))
       (define (extend inner-vars inner-names)
         (fold (lambda (var name vars)
                 (vhash-consq var (list name src) vars))
               vars
               inner-vars
               inner-names))

       (record-case x
         ((<lexical-set> gensym)
          (make-binding-info vars (vhash-consq gensym #t refs)))
         ((<lambda-case> req opt inits rest kw gensyms)
          (let ((names `(,@req
                         ,@(or opt '())
                         ,@(if rest (list rest) '())
                         ,@(if kw (map cadr (cdr kw)) '()))))
            (make-binding-info (extend gensyms names) refs)))
         ((<let> gensyms names)
          (make-binding-info (extend gensyms names) refs))
         ((<letrec> gensyms names)
          (make-binding-info (extend gensyms names) refs))
         ((<fix> gensyms names)
          (make-binding-info (extend gensyms names) refs))
         (else info))))

   (lambda (x info env locs)
     ;; Leaving X's scope: shrink INFO's variable list
     ;; accordingly and reported unused nested variables.
     (let ((refs (binding-info-refs info))
           (vars (binding-info-vars info)))
       (define (shrink inner-vars refs)
         (vlist-for-each
          (lambda (var)
            (let ((gensym (car var)))
              ;; Don't report lambda parameters as unused.
              (if (and (memq gensym inner-vars)
                       (not (vhash-assq gensym refs))
                       (not (lambda-case? x)))
                  (let ((name (cadr var))
                        ;; We can get approximate source location by going up
                        ;; the LOCS location stack.
                        (loc  (or (caddr var)
                                  (find pair? locs))))
                    (warning 'unused-variable loc name)))))
          vars)
         (vlist-drop vars (length inner-vars)))

       ;; For simplicity, we leave REFS untouched, i.e., with
       ;; names of variables that are now going out of scope.
       ;; It doesn't hurt as these are unique names, it just
       ;; makes REFS unnecessarily fat.
       (record-case x
         ((<lambda-case> gensyms)
          (make-binding-info (shrink gensyms refs) refs))
         ((<let> gensyms)
          (make-binding-info (shrink gensyms refs) refs))
         ((<letrec> gensyms)
          (make-binding-info (shrink gensyms refs) refs))
         ((<fix> gensyms)
          (make-binding-info (shrink gensyms refs) refs))
         (else info))))

   (lambda (result env) #t)
   (make-binding-info vlist-null vlist-null)))

;;;
;;; Unused top-level variable analysis.
;;;

;; <reference-graph> record top-level definitions that are made, references to
;; top-level definitions and their context (the top-level definition in which
;; the reference appears), as well as the current context (the top-level
;; definition we're currently in).  The second part (`refs' below) is
;; effectively a graph from which we can determine unused top-level definitions.
(define-record-type <reference-graph>
  (make-reference-graph refs defs toplevel-context)
  reference-graph?
  (defs             reference-graph-defs) ;; ((NAME . LOC) ...)
  (refs             reference-graph-refs) ;; ((REF-CONTEXT REF ...) ...)
  (toplevel-context reference-graph-toplevel-context)) ;; NAME | #f

(define (graph-reachable-nodes root refs reachable)
  ;; Add to REACHABLE the nodes reachable from ROOT in graph REFS.  REFS is a
  ;; vhash mapping nodes to the list of their children: for instance,
  ;; ((A -> (B C)) (B -> (A)) (C -> ())) corresponds to
  ;;
  ;;  ,-------.
  ;;  v       |
  ;;  A ----> B
  ;;  |
  ;;  v
  ;;  C
  ;;
  ;; REACHABLE is a vhash of nodes known to be otherwise reachable.

  (let loop ((root   root)
             (path   vlist-null)
             (result reachable))
    (if (or (vhash-assq root path)
            (vhash-assq root result))
        result
        (let* ((children (or (and=> (vhash-assq root refs) cdr) '()))
               (path     (vhash-consq root #t path))
               (result   (fold (lambda (kid result)
                                 (loop kid path result))
                               result
                               children)))
          (fold (lambda (kid result)
                  (vhash-consq kid #t result))
                result
                children)))))

(define (graph-reachable-nodes* roots refs)
  ;; Return the list of nodes in REFS reachable from the nodes listed in ROOTS.
  (vlist-fold (lambda (root+true result)
                (let* ((root      (car root+true))
                       (reachable (graph-reachable-nodes root refs result)))
                  (vhash-consq root #t reachable)))
              vlist-null
              roots))

(define (partition* pred vhash)
  ;; Partition VHASH according to PRED.  Return the two resulting vhashes.
  (let ((result
         (vlist-fold (lambda (k+v result)
                       (let ((k  (car k+v))
                             (v  (cdr k+v))
                             (r1 (car result))
                             (r2 (cdr result)))
                         (if (pred k)
                             (cons (vhash-consq k v r1) r2)
                             (cons r1 (vhash-consq k v r2)))))
                     (cons vlist-null vlist-null)
                     vhash)))
    (values (car result) (cdr result))))

(define unused-toplevel-analysis
  ;; Report unused top-level definitions that are not exported.
  (let ((add-ref-from-context
         (lambda (graph name)
           ;; Add an edge CTX -> NAME in GRAPH.
           (let* ((refs     (reference-graph-refs graph))
                  (defs     (reference-graph-defs graph))
                  (ctx      (reference-graph-toplevel-context graph))
                  (ctx-refs (or (and=> (vhash-assq ctx refs) cdr) '())))
             (make-reference-graph (vhash-consq ctx (cons name ctx-refs) refs)
                                   defs ctx)))))
    (define (macro-variable? name env)
      (and (module? env)
           (let ((var (module-variable env name)))
             (and var (variable-bound? var)
                  (macro? (variable-ref var))))))

    (make-tree-analysis
     (lambda (x graph env locs)
       ;; X is a leaf.
       (let ((ctx (reference-graph-toplevel-context graph)))
         (record-case x
           ((<toplevel-ref> name src)
            (add-ref-from-context graph name))
           (else graph))))

     (lambda (x graph env locs)
       ;; Going down into X.
       (let ((ctx  (reference-graph-toplevel-context graph))
             (refs (reference-graph-refs graph))
             (defs (reference-graph-defs graph)))
         (record-case x
           ((<toplevel-define> name src)
            (let ((refs refs)
                  (defs (vhash-consq name (or src (find pair? locs))
                                     defs)))
              (make-reference-graph refs defs name)))
           ((<toplevel-set> name src)
            (add-ref-from-context graph name))
           (else graph))))

     (lambda (x graph env locs)
       ;; Leaving X's scope.
       (record-case x
         ((<toplevel-define>)
          (let ((refs (reference-graph-refs graph))
                (defs (reference-graph-defs graph)))
            (make-reference-graph refs defs #f)))
         (else graph)))

     (lambda (graph env)
       ;; Process the resulting reference graph: determine all private definitions
       ;; not reachable from any public definition.  Macros
       ;; (syntax-transformers), which are globally bound, never considered
       ;; unused since we can't tell whether a macro is actually used; in
       ;; addition, macros are considered roots of the graph since they may use
       ;; private bindings.  FIXME: The `make-syntax-transformer' calls don't
       ;; contain any literal `toplevel-ref' of the global bindings they use so
       ;; this strategy fails.
       (define (exported? name)
         (if (module? env)
             (module-variable (module-public-interface env) name)
             #t))

       (let-values (((public-defs private-defs)
                     (partition* (lambda (name)
                                   (or (exported? name)
                                       (macro-variable? name env)))
                                 (reference-graph-defs graph))))
         (let* ((roots     (vhash-consq #f #t public-defs))
                (refs      (reference-graph-refs graph))
                (reachable (graph-reachable-nodes* roots refs))
                (unused    (vlist-filter (lambda (name+src)
                                           (not (vhash-assq (car name+src)
                                                            reachable)))
                                         private-defs)))
           (vlist-for-each (lambda (name+loc)
                             (let ((name (car name+loc))
                                   (loc  (cdr name+loc)))
                               (warning 'unused-toplevel loc name)))
                           unused))))

     (make-reference-graph vlist-null vlist-null #f))))

;;;
;;; Unbound variable analysis.
;;;

;; <toplevel-info> records are used during tree traversal in search of
;; possibly unbound variable.  They contain a list of references to
;; potentially unbound top-level variables, and a list of the top-level
;; defines that have been encountered.
(define-record-type <toplevel-info>
  (make-toplevel-info refs defs)
  toplevel-info?
  (refs  toplevel-info-refs)  ;; ((VARIABLE-NAME . LOCATION) ...)
  (defs  toplevel-info-defs)) ;; (VARIABLE-NAME ...)

(define (goops-toplevel-definition proc args env)
  ;; If application of PROC to ARGS is a GOOPS top-level definition, return
  ;; the name of the variable being defined; otherwise return #f.  This
  ;; assumes knowledge of the current implementation of `define-class' et al.
  (define (toplevel-define-arg args)
    (and (pair? args) (pair? (cdr args)) (null? (cddr args))
         (record-case (car args)
           ((<const> exp)
            (and (symbol? exp) exp))
           (else #f))))

  (record-case proc
    ((<module-ref> mod public? name)
     (and (equal? mod '(oop goops))
          (not public?)
          (eq? name 'toplevel-define!)
          (toplevel-define-arg args)))
    ((<toplevel-ref> name)
     ;; This may be the result of expanding one of the GOOPS macros within
     ;; `oop/goops.scm'.
     (and (eq? name 'toplevel-define!)
          (eq? env (resolve-module '(oop goops)))
          (toplevel-define-arg args)))
    (else #f)))

(define unbound-variable-analysis
  ;; Report possibly unbound variables in the given tree.
  (make-tree-analysis
   (lambda (x info env locs)
     ;; X is a leaf: extend INFO's refs accordingly.
     (let ((refs (toplevel-info-refs info))
           (defs (toplevel-info-defs info)))
       (define (bound? name)
         (or (and (module? env)
                  (module-variable env name))
             (vhash-assq name defs)))

       (record-case x
         ((<toplevel-ref> name src)
          (if (bound? name)
              info
              (let ((src (or src (find pair? locs))))
                (make-toplevel-info (vhash-consq name src refs)
                                    defs))))
         (else info))))

   (lambda (x info env locs)
     ;; Going down into X.
     (let* ((refs (toplevel-info-refs info))
            (defs (toplevel-info-defs info))
            (src  (tree-il-src x)))
       (define (bound? name)
         (or (and (module? env)
                  (module-variable env name))
             (vhash-assq name defs)))

       (record-case x
         ((<toplevel-set> name src)
          (if (bound? name)
              (make-toplevel-info refs defs)
              (let ((src (find pair? locs)))
                (make-toplevel-info (vhash-consq name src refs)
                                    defs))))
         ((<toplevel-define> name)
          (make-toplevel-info (vhash-delete name refs eq?)
                              (vhash-consq name #t defs)))

         ((<application> proc args)
          ;; Check for a dynamic top-level definition, as is
          ;; done by code expanded from GOOPS macros.
          (let ((name (goops-toplevel-definition proc args
                                                 env)))
            (if (symbol? name)
                (make-toplevel-info (vhash-delete name refs
                                                  eq?)
                                    (vhash-consq name #t defs))
                (make-toplevel-info refs defs))))
         (else
          (make-toplevel-info refs defs)))))

   (lambda (x info env locs)
     ;; Leaving X's scope.
     info)

   (lambda (toplevel env)
     ;; Post-process the result.
     (vlist-for-each (lambda (name+loc)
                       (let ((name (car name+loc))
                             (loc  (cdr name+loc)))
                         (warning 'unbound-variable loc name)))
                     (vlist-reverse (toplevel-info-refs toplevel))))

   (make-toplevel-info vlist-null vlist-null)))

;;;
;;; Arity analysis.
;;;

;; <arity-info> records contain information about lexical definitions of
;; procedures currently in scope, top-level procedure definitions that have
;; been encountered, and calls to top-level procedures that have been
;; encountered.
(define-record-type <arity-info>
  (make-arity-info toplevel-calls lexical-lambdas toplevel-lambdas)
  arity-info?
  (toplevel-calls   toplevel-procedure-calls) ;; ((NAME . APPLICATION) ...)
  (lexical-lambdas  lexical-lambdas)          ;; ((GENSYM . DEFINITION) ...)
  (toplevel-lambdas toplevel-lambdas))        ;; ((NAME . DEFINITION) ...)

(define (validate-arity proc application lexical?)
  ;; Validate the argument count of APPLICATION, a tree-il application of
  ;; PROC, emitting a warning in case of argument count mismatch.

  (define (filter-keyword-args keywords allow-other-keys? args)
    ;; Filter keyword arguments from ARGS and return the resulting list.
    ;; KEYWORDS is the list of allowed keywords, and ALLOW-OTHER-KEYS?
    ;; specified whethere keywords not listed in KEYWORDS are allowed.
    (let loop ((args   args)
               (result '()))
      (if (null? args)
          (reverse result)
          (let ((arg (car args)))
            (if (and (const? arg)
                     (or (memq (const-exp arg) keywords)
                         (and allow-other-keys?
                              (keyword? (const-exp arg)))))
                (loop (if (pair? (cdr args))
                          (cddr args)
                          '())
                      result)
                (loop (cdr args)
                      (cons arg result)))))))

  (define (arities proc)
    ;; Return the arities of PROC, which can be either a tree-il or a
    ;; procedure.
    (define (len x)
      (or (and (or (null? x) (pair? x))
               (length x))
          0))
    (cond ((program? proc)
           (values (procedure-name proc)
                   (map (lambda (a)
                          (list (arity:nreq a) (arity:nopt a) (arity:rest? a)
                                (map car (arity:kw a))
                                (arity:allow-other-keys? a)))
                        (program-arities proc))))
          ((procedure? proc)
           (let ((arity (procedure-minimum-arity proc)))
             (values (procedure-name proc)
                     (list (list (car arity) (cadr arity) (caddr arity)
                                 #f #f)))))
          (else
           (let loop ((name    #f)
                      (proc    proc)
                      (arities '()))
             (if (not proc)
                 (values name (reverse arities))
                 (record-case proc
                   ((<lambda-case> req opt rest kw alternate)
                    (loop name alternate
                          (cons (list (len req) (len opt) rest
                                      (and (pair? kw) (map car (cdr kw)))
                                      (and (pair? kw) (car kw)))
                                arities)))
                   ((<lambda> meta body)
                    (loop (assoc-ref meta 'name) body arities))
                   (else
                    (values #f #f))))))))

  (let ((args (application-args application))
        (src  (tree-il-src application)))
    (call-with-values (lambda () (arities proc))
      (lambda (name arities)
        (define matches?
          (find (lambda (arity)
                  (pmatch arity
                    ((,req ,opt ,rest? ,kw ,aok?)
                     (let ((args (if (pair? kw)
                                     (filter-keyword-args kw aok? args)
                                     args)))
                       (if (and req opt)
                           (let ((count (length args)))
                             (and (>= count req)
                                  (or rest?
                                      (<= count (+ req opt)))))
                           #t)))
                    (else #t)))
                arities))

        (if (not matches?)
            (warning 'arity-mismatch src
                     (or name (with-output-to-string (lambda () (write proc))))
                     lexical?)))))
  #t)

(define arity-analysis
  ;; Report arity mismatches in the given tree.
  (make-tree-analysis
   (lambda (x info env locs)
     ;; X is a leaf.
     info)
   (lambda (x info env locs)
     ;; Down into X.
     (define (extend lexical-name val info)
       ;; If VAL is a lambda, add NAME to the lexical-lambdas of INFO.
       (let ((toplevel-calls   (toplevel-procedure-calls info))
             (lexical-lambdas  (lexical-lambdas info))
             (toplevel-lambdas (toplevel-lambdas info)))
         (record-case val
           ((<lambda> body)
            (make-arity-info toplevel-calls
                             (vhash-consq lexical-name val
                                          lexical-lambdas)
                             toplevel-lambdas))
           ((<lexical-ref> gensym)
            ;; lexical alias
            (let ((val* (vhash-assq gensym lexical-lambdas)))
              (if (pair? val*)
                  (extend lexical-name (cdr val*) info)
                  info)))
           ((<toplevel-ref> name)
            ;; top-level alias
            (make-arity-info toplevel-calls
                             (vhash-consq lexical-name val
                                          lexical-lambdas)
                             toplevel-lambdas))
           (else info))))

     (let ((toplevel-calls   (toplevel-procedure-calls info))
           (lexical-lambdas  (lexical-lambdas info))
           (toplevel-lambdas (toplevel-lambdas info)))

       (record-case x
         ((<toplevel-define> name exp)
          (record-case exp
            ((<lambda> body)
             (make-arity-info toplevel-calls
                              lexical-lambdas
                              (vhash-consq name exp toplevel-lambdas)))
            ((<toplevel-ref> name)
             ;; alias for another toplevel
             (let ((proc (vhash-assq name toplevel-lambdas)))
               (make-arity-info toplevel-calls
                                lexical-lambdas
                                (vhash-consq (toplevel-define-name x)
                                             (if (pair? proc)
                                                 (cdr proc)
                                                 exp)
                                             toplevel-lambdas))))
            (else info)))
         ((<let> gensyms vals)
          (fold extend info gensyms vals))
         ((<letrec> gensyms vals)
          (fold extend info gensyms vals))
         ((<fix> gensyms vals)
          (fold extend info gensyms vals))

         ((<application> proc args src)
          (record-case proc
            ((<lambda> body)
             (validate-arity proc x #t)
             info)
            ((<toplevel-ref> name)
             (make-arity-info (vhash-consq name x toplevel-calls)
                              lexical-lambdas
                              toplevel-lambdas))
            ((<lexical-ref> gensym)
             (let ((proc (vhash-assq gensym lexical-lambdas)))
               (if (pair? proc)
                   (record-case (cdr proc)
                     ((<toplevel-ref> name)
                      ;; alias to toplevel
                      (make-arity-info (vhash-consq name x toplevel-calls)
                                       lexical-lambdas
                                       toplevel-lambdas))
                     (else
                      (validate-arity (cdr proc) x #t)
                      info))

                   ;; If GENSYM wasn't found, it may be because it's an
                   ;; argument of the procedure being compiled.
                   info)))
            (else info)))
         (else info))))

   (lambda (x info env locs)
     ;; Up from X.
     (define (shrink name val info)
       ;; Remove NAME from the lexical-lambdas of INFO.
       (let ((toplevel-calls   (toplevel-procedure-calls info))
             (lexical-lambdas  (lexical-lambdas info))
             (toplevel-lambdas (toplevel-lambdas info)))
         (make-arity-info toplevel-calls
                          (if (vhash-assq name lexical-lambdas)
                              (vlist-tail lexical-lambdas)
                              lexical-lambdas)
                          toplevel-lambdas)))

     (let ((toplevel-calls   (toplevel-procedure-calls info))
           (lexical-lambdas  (lexical-lambdas info))
           (toplevel-lambdas (toplevel-lambdas info)))
       (record-case x
         ((<let> gensyms vals)
          (fold shrink info gensyms vals))
         ((<letrec> gensyms vals)
          (fold shrink info gensyms vals))
         ((<fix> gensyms vals)
          (fold shrink info gensyms vals))

         (else info))))

   (lambda (result env)
     ;; Post-processing: check all top-level procedure calls that have been
     ;; encountered.
     (let ((toplevel-calls   (toplevel-procedure-calls result))
           (toplevel-lambdas (toplevel-lambdas result)))
       (vlist-for-each
        (lambda (name+application)
          (let* ((name        (car name+application))
                 (application (cdr name+application))
                 (proc
                  (or (and=> (vhash-assq name toplevel-lambdas) cdr)
                      (and (module? env)
                           (false-if-exception
                            (module-ref env name)))))
                 (proc*
                  ;; handle toplevel aliases
                  (if (toplevel-ref? proc)
                      (let ((name (toplevel-ref-name proc)))
                        (and (module? env)
                             (false-if-exception
                              (module-ref env name))))
                      proc)))
            (if (or (lambda? proc*) (procedure? proc*))
                (validate-arity proc* application (lambda? proc*)))))
        toplevel-calls)))

   (make-arity-info vlist-null vlist-null vlist-null)))


code:
;;; TREE-IL -> GLIL compiler

;; Copyright (C) 2001,2008,2009,2010 Free Software Foundation, Inc.

;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Code:

(define-module (language tree-il compile-glil)
  #:use-module (system base syntax)
  #:use-module (system base pmatch)
  #:use-module (system base message)
  #:use-module (ice-9 receive)
  #:use-module (language glil)
  #:use-module (system vm instruction)
  #:use-module (language tree-il)
  #:use-module (language tree-il optimize)
  #:use-module (language tree-il analyze)
  #:use-module ((srfi srfi-1) #:select (filter-map))
  #:export (compile-glil))

;; allocation:
;;  sym -> {lambda -> address}
;;  lambda -> (labels . free-locs)
;;  lambda-case -> (gensym . nlocs)
;;
;; address ::= (local? boxed? . index)
;; labels ::= ((sym . lambda) ...)
;; free-locs ::= ((sym0 . address0) (sym1 . address1) ...)
;; free variable addresses are relative to parent proc.

(define *comp-module* (make-fluid))

(define %warning-passes
  `((unused-variable     . ,unused-variable-analysis)
    (unused-toplevel     . ,unused-toplevel-analysis)
    (unbound-variable    . ,unbound-variable-analysis)
    (arity-mismatch      . ,arity-analysis)))

(define (compile-glil x e opts)
  (define warnings
    (or (and=> (memq #:warnings opts) cadr)
        '()))

  ;; Go through the warning passes.
  (let ((analyses (filter-map (lambda (kind)
                                (assoc-ref %warning-passes kind))
                              warnings)))
    (analyze-tree analyses x e))

  (let* ((x (make-lambda (tree-il-src x) '()
                         (make-lambda-case #f '() #f #f #f '() '() x #f)))
         (x (optimize! x e opts))
         (allocation (analyze-lexicals x)))

    (with-fluids ((*comp-module* e))
      (values (flatten-lambda x #f allocation)
              e
              e))))

(define *primcall-ops* (make-hash-table))
(for-each
 (lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
 '(((eq? . 2) . eq?)
   ((eqv? . 2) . eqv?)
   ((equal? . 2) . equal?)
   ((= . 2) . ee?)
   ((< . 2) . lt?)
   ((> . 2) . gt?)
   ((<= . 2) . le?)
   ((>= . 2) . ge?)
   ((+ . 2) . add)
   ((- . 2) . sub)
   ((1+ . 1) . add1)
   ((1- . 1) . sub1)
   ((* . 2) . mul)
   ((/ . 2) . div)
   ((quotient . 2) . quo)
   ((remainder . 2) . rem)
   ((modulo . 2) . mod)
   ((ash . 2) . ash)
   ((logand . 2) . logand)
   ((logior . 2) . logior)
   ((logxor . 2) . logxor)
   ((not . 1) . not)
   ((pair? . 1) . pair?)
   ((cons . 2) . cons)
   ((car . 1) . car)
   ((cdr . 1) . cdr)
   ((set-car! . 2) . set-car!)
   ((set-cdr! . 2) . set-cdr!)
   ((null? . 1) . null?)
   ((list? . 1) . list?)
   (list . list)
   (vector . vector)
   ((class-of . 1) . class-of)
   ((@slot-ref . 2) . slot-ref)
   ((@slot-set! . 3) . slot-set)
   ((vector-ref . 2) . vector-ref)
   ((vector-set! . 3) . vector-set)
   ((variable-ref . 1) . variable-ref)
   ;; nb, *not* variable-set! -- the args are switched
   ((variable-bound? . 1) . variable-bound?)
   ((struct? . 1) . struct?)
   ((struct-vtable . 1) . struct-vtable)
   ((struct-ref . 2) . struct-ref)
   ((struct-set! . 3) . struct-set)
   (make-struct/no-tail . make-struct)

   ;; hack for javascript
   ((return . 1) . return)

   ((bytevector-u8-ref . 2) . bv-u8-ref)
   ((bytevector-u8-set! . 3) . bv-u8-set)
   ((bytevector-s8-ref . 2) . bv-s8-ref)
   ((bytevector-s8-set! . 3) . bv-s8-set)

   ((bytevector-u16-ref . 3) . bv-u16-ref)
   ((bytevector-u16-set! . 4) . bv-u16-set)
   ((bytevector-u16-native-ref . 2) . bv-u16-native-ref)
   ((bytevector-u16-native-set! . 3) . bv-u16-native-set)
   ((bytevector-s16-ref . 3) . bv-s16-ref)
   ((bytevector-s16-set! . 4) . bv-s16-set)
   ((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
   ((bytevector-s16-native-set! . 3) . bv-s16-native-set)

   ((bytevector-u32-ref . 3) . bv-u32-ref)
   ((bytevector-u32-set! . 4) . bv-u32-set)
   ((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
   ((bytevector-u32-native-set! . 3) . bv-u32-native-set)
   ((bytevector-s32-ref . 3) . bv-s32-ref)
   ((bytevector-s32-set! . 4) . bv-s32-set)
   ((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
   ((bytevector-s32-native-set! . 3) . bv-s32-native-set)

   ((bytevector-u64-ref . 3) . bv-u64-ref)
   ((bytevector-u64-set! . 4) . bv-u64-set)
   ((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
   ((bytevector-u64-native-set! . 3) . bv-u64-native-set)
   ((bytevector-s64-ref . 3) . bv-s64-ref)
   ((bytevector-s64-set! . 4) . bv-s64-set)
   ((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
   ((bytevector-s64-native-set! . 3) . bv-s64-native-set)

   ((bytevector-ieee-single-ref . 3) . bv-f32-ref)
   ((bytevector-ieee-single-set! . 4) . bv-f32-set)
   ((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
   ((bytevector-ieee-single-native-set! . 3) . bv-f32-native-set)
   ((bytevector-ieee-double-ref . 3) . bv-f64-ref)
   ((bytevector-ieee-double-set! . 4) . bv-f64-set)
   ((bytevector-ieee-double-native-ref . 2) . bv-f64-native-ref)
   ((bytevector-ieee-double-native-set! . 3) . bv-f64-native-set)))

(define (make-label) (gensym ":L"))

(define (vars->bind-list ids vars allocation proc)
  (map (lambda (id v)
         (pmatch (hashq-ref (hashq-ref allocation v) proc)
           ((#t ,boxed? . ,n)
            (list id boxed? n))
           (,x (error "badness" id v x))))
       ids
       vars))

(define (emit-bindings src ids vars allocation proc emit-code)
  (emit-code src (make-glil-bind
                  (vars->bind-list ids vars allocation proc))))

(define (with-output-to-code proc)
  (let ((out '()))
    (define (emit-code src x)
      (set! out (cons x out))
      (if src
          (set! out (cons (make-glil-source src) out))))
    (proc emit-code)
    (reverse out)))

(define (flatten-lambda x self-label allocation)
  (record-case x
    ((<lambda> src meta body)
     (make-glil-program
      meta
      (with-output-to-code
       (lambda (emit-code)
         ;; write source info for proc
         (if src (emit-code #f (make-glil-source src)))
         ;; emit pre-prelude label for self tail calls in which the
         ;; number of arguments doesn't check out at compile time
         (if self-label
             (emit-code #f (make-glil-label self-label)))
         ;; compile the body, yo
         (flatten body allocation x self-label (car (hashq-ref allocation x))
                  emit-code)))))))

(define (flatten x allocation self self-label fix-labels emit-code)
  (define (emit-label label)
    (emit-code #f (make-glil-label label)))
  (define (emit-branch src inst label)
    (emit-code src (make-glil-branch inst label)))

  ;; RA: "return address"; #f unless we're in a non-tail fix with labels
  ;; MVRA: "multiple-values return address"; #f unless we're in a let-values
  (let comp ((x x) (context 'tail) (RA #f) (MVRA #f))
    (define (comp-tail tree) (comp tree context RA MVRA))
    (define (comp-push tree) (comp tree 'push #f #f))
    (define (comp-drop tree) (comp tree 'drop #f #f))
    (define (comp-vals tree MVRA) (comp tree 'vals #f MVRA))
    (define (comp-fix tree RA) (comp tree context RA MVRA))

    ;; A couple of helpers. Note that if we are in tail context, we
    ;; won't have an RA.
    (define (maybe-emit-return)
      (if RA
          (emit-branch #f 'br RA)
          (if (eq? context 'tail)
              (emit-code #f (make-glil-call 'return 1)))))

    (record-case x
      ((<void>)
       (case context
         ((push vals tail)
          (emit-code #f (make-glil-void))))
       (maybe-emit-return))

      ((<const> src exp)
       (case context
         ((push vals tail)
          (emit-code src (make-glil-const exp))))
       (maybe-emit-return))

      ;; FIXME: should represent sequence as exps tail
      ((<sequence> exps)
       (let lp ((exps exps))
         (if (null? (cdr exps))
             (comp-tail (car exps))
             (begin
               (comp-drop (car exps))
               (lp (cdr exps))))))

      ((<application> src proc args)
       ;; FIXME: need a better pattern-matcher here
       (cond
        ((and (primitive-ref? proc)
              (eq? (primitive-ref-name proc) '@apply)
              (>= (length args) 1))
         (let ((proc (car args))
               (args (cdr args)))
           (cond
            ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
                  (not (eq? context 'push)) (not (eq? context 'vals)))
             ;; tail: (lambda () (apply values '(1 2)))
             ;; drop: (lambda () (apply values '(1 2)) 3)
             ;; push: (lambda () (list (apply values '(10 12)) 1))
             (case context
               ((drop) (for-each comp-drop args) (maybe-emit-return))
               ((tail)
                (for-each comp-push args)
                (emit-code src (make-glil-call 'return/values* (length args))))))

            (else
             (case context
               ((tail)
                (comp-push proc)
                (for-each comp-push args)
                (emit-code src (make-glil-call 'tail-apply (1+ (length args)))))
               ((push)
                (emit-code src (make-glil-call 'new-frame 0))
                (comp-push proc)
                (for-each comp-push args)
                (emit-code src (make-glil-call 'apply (1+ (length args))))
                (maybe-emit-return))
               ((vals)
                (comp-vals
                 (make-application src (make-primitive-ref #f 'apply)
                                   (cons proc args))
                 MVRA)
                (maybe-emit-return))
               ((drop)
                ;; Well, shit. The proc might return any number of
                ;; values (including 0), since it's in a drop context,
                ;; yet apply does not create a MV continuation. So we
                ;; mv-call out to our trampoline instead.
                (comp-drop
                 (make-application src (make-primitive-ref #f 'apply)
                                   (cons proc args)))
                (maybe-emit-return)))))))

        ((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
              (not (eq? context 'push)))
         ;; tail: (lambda () (values '(1 2)))
         ;; drop: (lambda () (values '(1 2)) 3)
         ;; push: (lambda () (list (values '(10 12)) 1))
         ;; vals: (let-values (((a b ...) (values 1 2 ...))) ...)
         (case context
           ((drop) (for-each comp-drop args) (maybe-emit-return))
           ((vals)
            (for-each comp-push args)
            (emit-code #f (make-glil-const (length args)))
            (emit-branch src 'br MVRA))
           ((tail)
            (for-each comp-push args)
            (emit-code src (make-glil-call 'return/values (length args))))))

        ((and (primitive-ref? proc)
              (eq? (primitive-ref-name proc) '@call-with-values)
              (= (length args) 2))
	 ;; CONSUMER
         ;; PRODUCER
         ;; (mv-call MV)
         ;; ([tail]-call 1)
         ;; goto POST
         ;; MV: [tail-]call/nargs
         ;; POST: (maybe-drop)
         (case context
           ((vals)
            ;; Fall back.
            (comp-vals
             (make-application src (make-primitive-ref #f 'call-with-values)
                               args)
             MVRA)
            (maybe-emit-return))
           (else
            (let ((MV (make-label)) (POST (make-label))
                  (producer (car args)) (consumer (cadr args)))
              (if (not (eq? context 'tail))
                  (emit-code src (make-glil-call 'new-frame 0)))
              (comp-push consumer)
              (emit-code src (make-glil-call 'new-frame 0))
              (comp-push producer)
              (emit-code src (make-glil-mv-call 0 MV))
              (case context
                ((tail) (emit-code src (make-glil-call 'tail-call 1)))
                (else   (emit-code src (make-glil-call 'call 1))
                        (emit-branch #f 'br POST)))
              (emit-label MV)
              (case context
                ((tail) (emit-code src (make-glil-call 'tail-call/nargs 0)))
                (else   (emit-code src (make-glil-call 'call/nargs 0))
                        (emit-label POST)
                        (if (eq? context 'drop)
                            (emit-code #f (make-glil-call 'drop 1)))
                        (maybe-emit-return)))))))

        ((and (primitive-ref? proc)
              (eq? (primitive-ref-name proc) '@call-with-current-continuation)
              (= (length args) 1))
         (case context
           ((tail)
            (comp-push (car args))
            (emit-code src (make-glil-call 'tail-call/cc 1)))
           ((vals)
            (comp-vals
             (make-application
              src (make-primitive-ref #f 'call-with-current-continuation)
              args)
             MVRA)
            (maybe-emit-return))
           ((push)
            (comp-push (car args))
            (emit-code src (make-glil-call 'call/cc 1))
            (maybe-emit-return))
           ((drop)
            ;; Crap. Just like `apply' in drop context.
            (comp-drop
             (make-application
              src (make-primitive-ref #f 'call-with-current-continuation)
              args))
            (maybe-emit-return))))

        ;; A hack for variable-set, the opcode for which takes its args
        ;; reversed, relative to the variable-set! function
        ((and (primitive-ref? proc)
              (eq? (primitive-ref-name proc) 'variable-set!)
              (= (length args) 2))
         (comp-push (cadr args))
         (comp-push (car args))
         (emit-code src (make-glil-call 'variable-set 2))
         (case context
           ((tail push vals) (emit-code #f (make-glil-void))))
         (maybe-emit-return))

        ((and (primitive-ref? proc)
              (or (hash-ref *primcall-ops*
                            (cons (primitive-ref-name proc) (length args)))
                  (hash-ref *primcall-ops* (primitive-ref-name proc))))
         => (lambda (op)
              (for-each comp-push args)
              (emit-code src (make-glil-call op (length args)))
              (case (instruction-pushes op)
                ((0)
                 (case context
                   ((tail push vals) (emit-code #f (make-glil-void))))
                 (maybe-emit-return))
                ((1)
                 (case context
                   ((drop) (emit-code #f (make-glil-call 'drop 1))))
                 (maybe-emit-return))
                (else
                 (error "bad primitive op: too many pushes"
                        op (instruction-pushes op))))))

        ;; self-call in tail position
        ((and (lexical-ref? proc)
              self-label (eq? (lexical-ref-gensym proc) self-label)
              (eq? context 'tail))
         ;; first, evaluate new values, pushing them on the stack
         (for-each comp-push args)
         (let lp ((lcase (lambda-body self)))
           (cond
            ((and (lambda-case? lcase)
                  (not (lambda-case-kw lcase))
                  (not (lambda-case-opt lcase))
                  (not (lambda-case-rest lcase))
                  (= (length args) (length (lambda-case-req lcase))))
             ;; we have a case that matches the args; rename variables
             ;; and goto the case label
             (for-each (lambda (sym)
                         (pmatch (hashq-ref (hashq-ref allocation sym) self)
                           ((#t #f . ,index) ; unboxed
                            (emit-code #f (make-glil-lexical #t #f 'set index)))
                           ((#t #t . ,index) ; boxed
                            ;; new box
                            (emit-code #f (make-glil-lexical #t #t 'box index)))
                           (,x (error "what" x))))
                       (reverse (lambda-case-gensyms lcase)))
             (emit-branch src 'br (car (hashq-ref allocation lcase))))
            ((lambda-case? lcase)
             ;; no match, try next case
             (lp (lambda-case-alternate lcase)))
            (else
             ;; no cases left; shuffle args down and jump before the prelude.
             (for-each (lambda (i)
                         (emit-code #f (make-glil-lexical #t #f 'set i)))
                       (reverse (iota (length args))))
             (emit-branch src 'br self-label)))))

        ;; lambda, the ultimate goto
        ((and (lexical-ref? proc)
              (assq (lexical-ref-gensym proc) fix-labels))
         ;; like the self-tail-call case, though we can handle "drop"
         ;; contexts too. first, evaluate new values, pushing them on
         ;; the stack
         (for-each comp-push args)
         ;; find the specific case, rename args, and goto the case label
         (let lp ((lcase (lambda-body
                          (assq-ref fix-labels (lexical-ref-gensym proc)))))
           (cond
            ((and (lambda-case? lcase)
                  (not (lambda-case-kw lcase))
                  (not (lambda-case-opt lcase))
                  (not (lambda-case-rest lcase))
                  (= (length args) (length (lambda-case-req lcase))))
             ;; we have a case that matches the args; rename variables
             ;; and goto the case label
             (for-each (lambda (sym)
                         (pmatch (hashq-ref (hashq-ref allocation sym) self)
                           ((#t #f . ,index) ; unboxed
                            (emit-code #f (make-glil-lexical #t #f 'set index)))
                           ((#t #t . ,index) ; boxed
                            (emit-code #f (make-glil-lexical #t #t 'box index)))
                           (,x (error "what" x))))
                       (reverse (lambda-case-gensyms lcase)))
             (emit-branch src 'br (car (hashq-ref allocation lcase))))
            ((lambda-case? lcase)
             ;; no match, try next case
             (lp (lambda-case-alternate lcase)))
            (else
             ;; no cases left. we can't really handle this currently.
             ;; ideally we would push on a new frame, then do a "local
             ;; call" -- which doesn't require consing up a program
             ;; object. but for now error, as this sort of case should
             ;; preclude label allocation.
             (error "couldn't find matching case for label call" x)))))

        (else
         (if (not (eq? context 'tail))
             (emit-code src (make-glil-call 'new-frame 0)))
         (comp-push proc)
         (for-each comp-push args)
         (let ((len (length args)))
           (case context
             ((tail) (emit-code src (make-glil-call 'tail-call len)))
             ((push) (emit-code src (make-glil-call 'call len))
                     (maybe-emit-return))
             ((vals) (emit-code src (make-glil-mv-call len MVRA))
                     (maybe-emit-return))
             ((drop) (let ((MV (make-label)) (POST (make-label)))
                       (emit-code src (make-glil-mv-call len MV))
                       (emit-code #f (make-glil-call 'drop 1))
                       (emit-branch #f 'br (or RA POST))
                       (emit-label MV)
                       (emit-code #f (make-glil-mv-bind 0 #f))
                       (if RA
                           (emit-branch #f 'br RA)
                           (emit-label POST)))))))))

      ((<conditional> src test consequent alternate)
       ;;     TEST
       ;;     (br-if-not L1)
       ;;     consequent
       ;;     (br L2)
       ;; L1: alternate
       ;; L2:
       (let ((L1 (make-label)) (L2 (make-label)))
         ;; need a pattern matcher
         (record-case test
           ((<application> proc args)
            (record-case proc
              ((<primitive-ref> name)
               (let ((len (length args)))
                 (cond

                  ((and (eq? name 'eq?) (= len 2))
                   (comp-push (car args))
                   (comp-push (cadr args))
                   (emit-branch src 'br-if-not-eq L1))

                  ((and (eq? name 'null?) (= len 1))
                   (comp-push (car args))
                   (emit-branch src 'br-if-not-null L1))

                  ((and (eq? name 'not) (= len 1))
                   (let ((app (car args)))
                     (record-case app
                       ((<application> proc args)
                        (let ((len (length args)))
                          (record-case proc
                            ((<primitive-ref> name)
                             (cond

                              ((and (eq? name 'eq?) (= len 2))
                               (comp-push (car args))
                               (comp-push (cadr args))
                               (emit-branch src 'br-if-eq L1))

                              ((and (eq? name 'null?) (= len 1))
                               (comp-push (car args))
                               (emit-branch src 'br-if-null L1))

                              (else
                               (comp-push app)
                               (emit-branch src 'br-if L1))))
                            (else
                             (comp-push app)
                             (emit-branch src 'br-if L1)))))
                       (else
                        (comp-push app)
                        (emit-branch src 'br-if L1)))))

                  (else
                   (comp-push test)
                   (emit-branch src 'br-if-not L1)))))
              (else
               (comp-push test)
               (emit-branch src 'br-if-not L1))))
           (else
            (comp-push test)
            (emit-branch src 'br-if-not L1)))

         (comp-tail consequent)
         ;; if there is an RA, comp-tail will cause a jump to it -- just
         ;; have to clean up here if there is no RA.
         (if (and (not RA) (not (eq? context 'tail)))
             (emit-branch #f 'br L2))
         (emit-label L1)
         (comp-tail alternate)
         (if (and (not RA) (not (eq? context 'tail)))
             (emit-label L2))))

      ((<primitive-ref> src name)
       (cond
        ((eq? (module-variable (fluid-ref *comp-module*) name)
              (module-variable the-root-module name))
         (case context
           ((tail push vals)
            (emit-code src (make-glil-toplevel 'ref name))))
         (maybe-emit-return))
        ((module-variable the-root-module name)
         (case context
           ((tail push vals)
            (emit-code src (make-glil-module 'ref '(guile) name #f))))
         (maybe-emit-return))
        (else
         (case context
           ((tail push vals)
            (emit-code src (make-glil-module
                            'ref (module-name (fluid-ref *comp-module*)) name #f))))
         (maybe-emit-return))))

      ((<lexical-ref> src gensym)
       (case context
         ((push vals tail)
          (pmatch (hashq-ref (hashq-ref allocation gensym) self)
            ((,local? ,boxed? . ,index)
             (emit-code src (make-glil-lexical local? boxed? 'ref index)))
            (,loc
             (error "badness" x loc)))))
       (maybe-emit-return))

      ((<lexical-set> src gensym exp)
       (comp-push exp)
       (pmatch (hashq-ref (hashq-ref allocation gensym) self)
         ((,local? ,boxed? . ,index)
          (emit-code src (make-glil-lexical local? boxed? 'set index)))
         (,loc
          (error "badness" x loc)))
       (case context
         ((tail push vals)
          (emit-code #f (make-glil-void))))
       (maybe-emit-return))

      ((<module-ref> src mod name public?)
       (emit-code src (make-glil-module 'ref mod name public?))
       (case context
         ((drop) (emit-code #f (make-glil-call 'drop 1))))
       (maybe-emit-return))

      ((<module-set> src mod name public? exp)
       (comp-push exp)
       (emit-code src (make-glil-module 'set mod name public?))
       (case context
         ((tail push vals)
          (emit-code #f (make-glil-void))))
       (maybe-emit-return))

      ((<toplevel-ref> src name)
       (emit-code src (make-glil-toplevel 'ref name))
       (case context
         ((drop) (emit-code #f (make-glil-call 'drop 1))))
       (maybe-emit-return))

      ((<toplevel-set> src name exp)
       (comp-push exp)
       (emit-code src (make-glil-toplevel 'set name))
       (case context
         ((tail push vals)
          (emit-code #f (make-glil-void))))
       (maybe-emit-return))

      ((<toplevel-define> src name exp)
       (comp-push exp)
       (emit-code src (make-glil-toplevel 'define name))
       (case context
         ((tail push vals)
          (emit-code #f (make-glil-void))))
       (maybe-emit-return))

      ((<lambda>)
       (let ((free-locs (cdr (hashq-ref allocation x))))
         (case context
           ((push vals tail)
            (emit-code #f (flatten-lambda x #f allocation))
            (if (not (null? free-locs))
                (begin
                  (for-each
                   (lambda (loc)
                     (pmatch loc
                       ((,local? ,boxed? . ,n)
                        (emit-code #f (make-glil-lexical local? #f 'ref n)))
                       (else (error "what" x loc))))
                   free-locs)
                  (emit-code #f (make-glil-call 'make-closure
                                                (length free-locs))))))))
       (maybe-emit-return))

      ((<lambda-case> src req opt rest kw inits gensyms alternate body)
       ;; o/~ feature on top of feature o/~
       ;; req := (name ...)
       ;; opt := (name ...) | #f
       ;; rest := name | #f
       ;; kw: (allow-other-keys? (keyword name var) ...) | #f
       ;; gensyms: (sym ...)
       ;; init: tree-il in context of gensyms
       ;; gensyms map to named arguments in the following order:
       ;;  required, optional (positional), rest, keyword.
       (let* ((nreq (length req))
              (nopt (if opt (length opt) 0))
              (rest-idx (and rest (+ nreq nopt)))
              (opt-names (or opt '()))
              (allow-other-keys? (if kw (car kw) #f))
              (kw-indices (map (lambda (x)
                                 (pmatch x
                                   ((,key ,name ,var)
                                    (cons key (list-index gensyms var)))
                                   (else (error "bad kwarg" x))))
                               (if kw (cdr kw) '())))
              (nargs (apply max (+ nreq nopt (if rest 1 0))
                            (map 1+ (map cdr kw-indices))))
              (nlocs (cdr (hashq-ref allocation x)))
              (alternate-label (and alternate (make-label))))
         (or (= nargs
                (length gensyms)
                (+ nreq (length inits) (if rest 1 0)))
             (error "something went wrong"
                    req opt rest kw inits gensyms nreq nopt kw-indices nargs))
         ;; the prelude, to check args & reset the stack pointer,
         ;; allowing room for locals
         (emit-code
          src
          (cond
           (kw
            (make-glil-kw-prelude nreq nopt rest-idx kw-indices
                                  allow-other-keys? nlocs alternate-label))
           ((or rest opt)
            (make-glil-opt-prelude nreq nopt rest-idx nlocs alternate-label))
           (#t
            (make-glil-std-prelude nreq nlocs alternate-label))))
         ;; box args if necessary
         (for-each
          (lambda (v)
            (pmatch (hashq-ref (hashq-ref allocation v) self)
              ((#t #t . ,n)
               (emit-code #f (make-glil-lexical #t #f 'ref n))
               (emit-code #f (make-glil-lexical #t #t 'box n)))))
          gensyms)
         ;; write bindings info
         (if (not (null? gensyms))
             (emit-bindings
              #f
              (let lp ((kw (if kw (cdr kw) '()))
                       (names (append (reverse opt-names) (reverse req)))
                       (gensyms (list-tail gensyms (+ nreq nopt
                                                (if rest 1 0)))))
                (pmatch kw
                  (()
                   ;; fixme: check that gensyms is empty
                   (reverse (if rest (cons rest names) names)))
                  (((,key ,name ,var) . ,kw)
                   (if (memq var gensyms)
                       (lp kw (cons name names) (delq var gensyms))
                       (lp kw names gensyms)))
                  (,kw (error "bad keywords, yo" kw))))
              gensyms allocation self emit-code))
         ;; init optional/kw args
         (let lp ((inits inits) (n nreq) (gensyms (list-tail gensyms nreq)))
           (cond
            ((null? inits))             ; done
            ((and rest-idx (= n rest-idx))
             (lp inits (1+ n) (cdr gensyms)))
            (#t
             (pmatch (hashq-ref (hashq-ref allocation (car gensyms)) self)
               ((#t ,boxed? . ,n*) (guard (= n* n))
                (let ((L (make-label)))
                  (emit-code #f (make-glil-lexical #t boxed? 'bound? n))
                  (emit-code #f (make-glil-branch 'br-if L))
                  (comp-push (car inits))
                  (emit-code #f (make-glil-lexical #t boxed? 'set n))
                  (emit-label L)
                  (lp (cdr inits) (1+ n) (cdr gensyms))))
               (#t (error "what" inits))))))
         ;; post-prelude case label for label calls
         (emit-label (car (hashq-ref allocation x)))
         (comp-tail body)
         (if (not (null? gensyms))
             (emit-code #f (make-glil-unbind)))
         (if alternate-label
             (begin
               (emit-label alternate-label)
               (comp-tail alternate)))))

      ((<let> src names gensyms vals body)
       (for-each comp-push vals)
       (emit-bindings src names gensyms allocation self emit-code)
       (for-each (lambda (v)
                   (pmatch (hashq-ref (hashq-ref allocation v) self)
                     ((#t #f . ,n)
                      (emit-code src (make-glil-lexical #t #f 'set n)))
                     ((#t #t . ,n)
                      (emit-code src (make-glil-lexical #t #t 'box n)))
                     (,loc (error "badness" x loc))))
                 (reverse gensyms))
       (comp-tail body)
       (emit-code #f (make-glil-unbind)))

      ((<letrec> src in-order? names gensyms vals body)
       ;; First prepare heap storage slots.
       (for-each (lambda (v)
                   (pmatch (hashq-ref (hashq-ref allocation v) self)
                     ((#t #t . ,n)
                      (emit-code src (make-glil-lexical #t #t 'empty-box n)))
                     (,loc (error "badness" x loc))))
                 gensyms)
       ;; Even though the slots are empty, the bindings are valid.
       (emit-bindings src names gensyms allocation self emit-code)
       (cond
        (in-order?
         ;; For letrec*, bind values in order.
         (for-each (lambda (name v val)
                     (pmatch (hashq-ref (hashq-ref allocation v) self)
                       ((#t #t . ,n)
                        (comp-push val)
                        (emit-code src (make-glil-lexical #t #t 'set n)))
                       (,loc (error "badness" x loc))))
                   names gensyms vals))
        (else
         ;; But for letrec, eval all values, then bind.
         (for-each comp-push vals)
         (for-each (lambda (v)
                     (pmatch (hashq-ref (hashq-ref allocation v) self)
                       ((#t #t . ,n)
                        (emit-code src (make-glil-lexical #t #t 'set n)))
                       (,loc (error "badness" x loc))))
                   (reverse gensyms))))
       (comp-tail body)
       (emit-code #f (make-glil-unbind)))

      ((<fix> src names gensyms vals body)
       ;; The ideal here is to just render the lambda bodies inline, and
       ;; wire the code together with gotos. We can do that if
       ;; analyze-lexicals has determined that a given var has "label"
       ;; allocation -- which is the case if it is in `fix-labels'.
       ;;
       ;; But even for closures that we can't inline, we can do some
       ;; tricks to avoid heap-allocation for the binding itself. Since
       ;; we know the vals are lambdas, we can set them to their local
       ;; var slots first, then capture their bindings, mutating them in
       ;; place.
       (let ((new-RA (if (or (eq? context 'tail) RA) #f (make-label))))
         (for-each
          (lambda (x v)
            (cond
             ((hashq-ref allocation x)
              ;; allocating a closure
              (emit-code #f (flatten-lambda x v allocation))
              (let ((free-locs (cdr (hashq-ref allocation x))))
                (if (not (null? free-locs))
                    ;; Need to make-closure first, so we have a fresh closure on
                    ;; the heap, but with a temporary free values.
                    (begin
                      (for-each (lambda (loc)
                                  (emit-code #f (make-glil-const #f)))
                                free-locs)
                      (emit-code #f (make-glil-call 'make-closure
                                                    (length free-locs))))))
              (pmatch (hashq-ref (hashq-ref allocation v) self)
                ((#t #f . ,n)
                 (emit-code src (make-glil-lexical #t #f 'set n)))
                (,loc (error "badness" x loc))))
             (else
              ;; labels allocation: emit label & body, but jump over it
              (let ((POST (make-label)))
                (emit-branch #f 'br POST)
                (let lp ((lcase (lambda-body x)))
                  (if lcase
                      (record-case lcase
                        ((<lambda-case> src req gensyms body alternate)
                         (emit-label (car (hashq-ref allocation lcase)))
                         ;; FIXME: opt & kw args in the bindings
                         (emit-bindings #f req gensyms allocation self emit-code)
                         (if src
                             (emit-code #f (make-glil-source src)))
                         (comp-fix body (or RA new-RA))
                         (emit-code #f (make-glil-unbind))
                         (lp alternate)))
                      (emit-label POST)))))))
          vals
          gensyms)
         ;; Emit bindings metadata for closures
         (let ((binds (let lp ((out '()) (gensyms gensyms) (names names))
                        (cond ((null? gensyms) (reverse! out))
                              ((assq (car gensyms) fix-labels)
                               (lp out (cdr gensyms) (cdr names)))
                              (else
                               (lp (acons (car gensyms) (car names) out)
                                   (cdr gensyms) (cdr names)))))))
           (emit-bindings src (map cdr binds) (map car binds)
                          allocation self emit-code))
         ;; Now go back and fix up the bindings for closures.
         (for-each
          (lambda (x v)
            (let ((free-locs (if (hashq-ref allocation x)
                                 (cdr (hashq-ref allocation x))
                                 ;; can hit this latter case for labels allocation
                                 '())))
              (if (not (null? free-locs))
                  (begin
                    (for-each
                     (lambda (loc)
                       (pmatch loc
                         ((,local? ,boxed? . ,n)
                          (emit-code #f (make-glil-lexical local? #f 'ref n)))
                         (else (error "what" x loc))))
                     free-locs)
                    (pmatch (hashq-ref (hashq-ref allocation v) self)
                      ((#t #f . ,n)
                       (emit-code #f (make-glil-lexical #t #f 'fix n)))
                      (,loc (error "badness" x loc)))))))
          vals
          gensyms)
         (comp-tail body)
         (if new-RA
             (emit-label new-RA))
         (emit-code #f (make-glil-unbind))))

      ((<let-values> src exp body)
       (record-case body
         ((<lambda-case> req opt kw rest gensyms body alternate)
          (if (or opt kw alternate)
              (error "unexpected lambda-case in let-values" x))
          (let ((MV (make-label)))
            (comp-vals exp MV)
            (emit-code #f (make-glil-const 1))
            (emit-label MV)
            (emit-code src (make-glil-mv-bind
                            (vars->bind-list
                             (append req (if rest (list rest) '()))
                             gensyms allocation self)
                            (and rest #t)))
            (for-each (lambda (v)
                        (pmatch (hashq-ref (hashq-ref allocation v) self)
                          ((#t #f . ,n)
                           (emit-code src (make-glil-lexical #t #f 'set n)))
                          ((#t #t . ,n)
                           (emit-code src (make-glil-lexical #t #t 'box n)))
                          (,loc (error "badness" x loc))))
                      (reverse gensyms))
            (comp-tail body)
            (emit-code #f (make-glil-unbind))))))

      ;; much trickier than i thought this would be, at first, due to the need
      ;; to have body's return value(s) on the stack while the unwinder runs,
      ;; then proceed with returning or dropping or what-have-you, interacting
      ;; with RA and MVRA. What have you, I say.
      ((<dynwind> src body winder unwinder)
       (comp-push winder)
       (comp-push unwinder)
       (comp-drop (make-application src winder '()))
       (emit-code #f (make-glil-call 'wind 2))

       (case context
         ((tail)
          (let ((MV (make-label)))
            (comp-vals body MV)
            ;; one value: unwind...
            (emit-code #f (make-glil-call 'unwind 0))
            (comp-drop (make-application src unwinder '()))
            ;; ...and return the val
            (emit-code #f (make-glil-call 'return 1))

            (emit-label MV)
            ;; multiple values: unwind...
            (emit-code #f (make-glil-call 'unwind 0))
            (comp-drop (make-application src unwinder '()))
            ;; and return the values.
            (emit-code #f (make-glil-call 'return/nvalues 1))))

         ((push)
          ;; we only want one value. so ask for one value
          (comp-push body)
          ;; and unwind, leaving the val on the stack
          (emit-code #f (make-glil-call 'unwind 0))
          (comp-drop (make-application src unwinder '())))

         ((vals)
          (let ((MV (make-label)))
            (comp-vals body MV)
            ;; one value: push 1 and fall through to MV case
            (emit-code #f (make-glil-const 1))

            (emit-label MV)
            ;; multiple values: unwind...
            (emit-code #f (make-glil-call 'unwind 0))
            (comp-drop (make-application src unwinder '()))
            ;; and goto the MVRA.
            (emit-branch #f 'br MVRA)))

         ((drop)
          ;; compile body, discarding values. then unwind...
          (comp-drop body)
          (emit-code #f (make-glil-call 'unwind 0))
          (comp-drop (make-application src unwinder '()))
          ;; and fall through, or goto RA if there is one.
          (if RA
              (emit-branch #f 'br RA)))))

      ((<dynlet> src fluids vals body)
       (for-each comp-push fluids)
       (for-each comp-push vals)
       (emit-code #f (make-glil-call 'wind-fluids (length fluids)))

       (case context
         ((tail)
          (let ((MV (make-label)))
            ;; NB: in tail case, it is possible to preserve asymptotic tail
            ;; recursion, via merging unwind-fluids structures -- but we'd need
            ;; to compile in the body twice (once in tail context, assuming the
            ;; caller unwinds, and once with this trampoline thing, unwinding
            ;; ourselves).
            (comp-vals body MV)
            ;; one value: unwind and return
            (emit-code #f (make-glil-call 'unwind-fluids 0))
            (emit-code #f (make-glil-call 'return 1))

            (emit-label MV)
            ;; multiple values: unwind and return values
            (emit-code #f (make-glil-call 'unwind-fluids 0))
            (emit-code #f (make-glil-call 'return/nvalues 1))))

         ((push)
          (comp-push body)
          (emit-code #f (make-glil-call 'unwind-fluids 0)))

         ((vals)
          (let ((MV (make-label)))
            (comp-vals body MV)
            ;; one value: push 1 and fall through to MV case
            (emit-code #f (make-glil-const 1))

            (emit-label MV)
            ;; multiple values: unwind and goto MVRA
            (emit-code #f (make-glil-call 'unwind-fluids 0))
            (emit-branch #f 'br MVRA)))

         ((drop)
          ;; compile body, discarding values. then unwind...
          (comp-drop body)
          (emit-code #f (make-glil-call 'unwind-fluids 0))
          ;; and fall through, or goto RA if there is one.
          (if RA
              (emit-branch #f 'br RA)))))

      ((<dynref> src fluid)
       (case context
         ((drop)
          (comp-drop fluid))
         ((push vals tail)
          (comp-push fluid)
          (emit-code #f (make-glil-call 'fluid-ref 1))))
       (maybe-emit-return))

      ((<dynset> src fluid exp)
       (comp-push fluid)
       (comp-push exp)
       (emit-code #f (make-glil-call 'fluid-set 2))
       (case context
         ((push vals tail)
          (emit-code #f (make-glil-void))))
       (maybe-emit-return))

      ;; What's the deal here? The deal is that we are compiling the start of a
      ;; delimited continuation. We try to avoid heap allocation in the normal
      ;; case; so the body is an expression, not a thunk, and we try to render
      ;; the handler inline. Also we did some analysis, in analyze.scm, so that
      ;; if the continuation isn't referenced, we don't reify it. This makes it
      ;; possible to implement catch and throw with delimited continuations,
      ;; without any overhead.
      ((<prompt> src tag body handler)
       (let ((H (make-label))
             (POST (make-label))
             (escape-only? (hashq-ref allocation x)))
         ;; First, set up the prompt.
         (comp-push tag)
         (emit-code src (make-glil-prompt H escape-only?))

         ;; Then we compile the body, with its normal return path, unwinding
         ;; before proceeding.
         (case context
           ((tail)
            (let ((MV (make-label)))
              (comp-vals body MV)
              ;; one value: unwind and return
              (emit-code #f (make-glil-call 'unwind 0))
              (emit-code #f (make-glil-call 'return 1))
              ;; multiple values: unwind and return
              (emit-label MV)
              (emit-code #f (make-glil-call 'unwind 0))
              (emit-code #f (make-glil-call 'return/nvalues 1))))

           ((push)
            ;; we only want one value. so ask for one value, unwind, and jump to
            ;; post
            (comp-push body)
            (emit-code #f (make-glil-call 'unwind 0))
            (emit-branch #f 'br POST))

           ((vals)
            (let ((MV (make-label)))
              (comp-vals body MV)
              ;; one value: push 1 and fall through to MV case
              (emit-code #f (make-glil-const 1))
              ;; multiple values: unwind and goto MVRA
              (emit-label MV)
              (emit-code #f (make-glil-call 'unwind 0))
              (emit-branch #f 'br MVRA)))

           ((drop)
            ;; compile body, discarding values, then unwind & fall through.
            (comp-drop body)
            (emit-code #f (make-glil-call 'unwind 0))
            (emit-branch #f 'br (or RA POST))))

         (emit-label H)
         ;; Now the handler. The stack is now made up of the continuation, and
         ;; then the args to the continuation (pushed separately), and then the
         ;; number of args, including the continuation.
         (record-case handler
           ((<lambda-case> req opt kw rest gensyms body alternate)
            (if (or opt kw alternate)
                (error "unexpected lambda-case in prompt" x))
            (emit-code src (make-glil-mv-bind
                            (vars->bind-list
                             (append req (if rest (list rest) '()))
                             gensyms allocation self)
                            (and rest #t)))
            (for-each (lambda (v)
                        (pmatch (hashq-ref (hashq-ref allocation v) self)
                          ((#t #f . ,n)
                           (emit-code src (make-glil-lexical #t #f 'set n)))
                          ((#t #t . ,n)
                           (emit-code src (make-glil-lexical #t #t 'box n)))
                          (,loc (error "badness" x loc))))
                      (reverse gensyms))
            (comp-tail body)
            (emit-code #f (make-glil-unbind))))

         (if (or (eq? context 'push)
                 (and (eq? context 'drop) (not RA)))
             (emit-label POST))))

      ((<abort> src tag args tail)
       (comp-push tag)
       (for-each comp-push args)
       (comp-push tail)
       (emit-code src (make-glil-call 'abort (length args)))
       ;; so, the abort can actually return. if it does, the values will be on
       ;; the stack, then the MV marker, just as in an MV context.
       (case context
         ((tail)
          ;; Return values.
          (emit-code #f (make-glil-call 'return/nvalues 1)))
         ((drop)
          ;; Drop all values and goto RA, or otherwise fall through.
          (emit-code #f (make-glil-mv-bind 0 #f))
          (if RA (emit-branch #f 'br RA)))
         ((push)
          ;; Truncate to one value.
          (emit-code #f (make-glil-mv-bind 1 #f)))
         ((vals)
          ;; Go to MVRA.
          (emit-branch #f 'br MVRA)))))))

license: mit