;;;; built-in compiler

;; code generation state, constant tables, bytecode encoding
(def (make-code-emitter) (vec NIL (table) 0 NIL 0 0))
(defmacro (bcode:code   b) `(aref ,b 0))
(defmacro (bcode:ctable b) `(aref ,b 1))
(defmacro (bcode:nconst b) `(aref ,b 2))
(defmacro (bcode:cenv   b) `(aref ,b 3))
(defmacro (bcode:sp     b) `(aref ,b 4))
(defmacro (bcode:spmax  b) `(aref ,b 5))
(def (bcode:stack b n)
  (let ((sp (+ (bcode:sp b) n)))
    (when (> sp (bcode:spmax b))
      (aset! b 5 sp))
    (aset! b 4 sp)))

(def (compile-error . rest)
  (apply error (cons "compile: " rest)))

;; get an index for a referenced value in a bytecode object
(def (bcode:indexfor b v)
  (let ((const-to-idx (bcode:ctable b))
        (nconst       (bcode:nconst b)))
    (if (has? const-to-idx v)
        (get const-to-idx v)
        (put! const-to-idx v nconst)
        (prog1 nconst
               (aset! b 2 (+ nconst 1))))))

(def (emit e inst . args)
  (def (load? i)
    (memq i '(load0 load1))) ; FIXME no load immediate here yet
  (let ((bc (aref e 0)))
    (if (not args)
        (if (and (eq? inst 'car)
                 (eq? (car bc) 'cdr))
            (set-car! bc 'cadr)
            (cond ((and (eq? inst 'pop) (load? (car bc)))
                   (aset! e 0 (cdr bc)))
                  (else
                   (aset! e 0 (cons inst bc)))))
        (when (memq inst '(loadv loadg setg))
          (set! args (list (bcode:indexfor e (car args)))))
        (let ((longform
               (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
                            (loada loada.l) (seta  seta.l)  (box  box.l)))))
          (when (and longform (> (car args) 255))
            (set! inst (cadr longform))))
        (let ((longform
               (assq inst '((loadc loadc.l)))))
          (when (and longform (> (car  args) 255))
            (set! inst (cadr longform))))
        (let ((lasti (car bc)))
          (cond ((and (eq? inst 'brn)
                      (cond ((eq? lasti 'not)
                             (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
                            ((eq? lasti 'eq?)
                             (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
                            (else NIL))))
                (else
                 (aset! e 0 (nreconc (cons inst args) bc))))))
    e))

(defmacro (make-label e)   `(gensym))
(defmacro (mark-label e l) `(emit ,e 'label ,l))

;; convert symbolic bytecode representation to a byte array.
;; labels are fixed-up.
(def (encode-byte-code e)
  (let* {[cl (reverse! e)]
         [v (list->vec cl)]
         [n (length v)]
         [long? (>= (+ n  ;; 1 byte for each entry, plus...
                          ;; at most half the entries in this vector can be
                          ;; instructions accepting 32-bit arguments
                       (* 3 (div0 n 2)))
                    65536)]
         [label-to-loc (table)]
         [fixup-to-label (table)]
         [bcode (buffer)]
         [vi NIL]
         [nxt NIL]
         [i 0]}
    (while (< i n)
      (set! vi (aref v i))
      (if (eq? vi 'label)
          (begin (put! label-to-loc (aref v (+ i 1)) (size-of bcode))
                 (set! i (+ i 2)))
          (io-write bcode
                    (get Instructions
                         (if long?
                             (case vi
                               (jmp  'jmp.l)
                               (brne 'brne.l)
                               (brnn 'brnn.l)
                               (brn  'brn.l)
                               (else vi))
                             vi)))
          (set! i (+ i 1)
                nxt (and (< i n) (aref v i)))
          (cond ((memq vi '(jmp brne brnn brn))
                 (put! fixup-to-label (size-of bcode) nxt)
                 (io-write bcode ((if long? s32 s16) 0))
                 (set! i (+ i 1)))
                ((eq? vi 'bounda)
                 (io-write bcode (s32 nxt) :little-endian)
                 (set! i (+ i 1)))
                ((num? nxt)
                 (case vi
                   ((loadv.l loadg.l setg.l loada.l seta.l
                     argc.l vargc.l call.l tcall.l loadc.l box.l)
                    (io-write bcode (s32 nxt) :little-endian)
                    (set! i (+ i 1)))

                   ((optargs keyargs)  ; 2 s32 args
                    (io-write bcode (s32 nxt) :little-endian)
                    (set! i (+ i 1))
                    (io-write bcode (s32 (aref v i)) :little-endian)
                    (set! i (+ i 1))
                    (when (eq? vi 'keyargs)
                      (io-write bcode (s32 (aref v i)) :little-endian)
                      (set! i (+ i 1))))

                   (else
                    ; other number arguments are always u8
                    (io-write bcode (u8 nxt))
                    (set! i (+ i 1)))))
                (else NIL))))

    (for-each
     (λ (addr labl)
       (io-pos! bcode addr)
       (io-write bcode ((if long? s32 s16)
                        (- (get label-to-loc labl) addr))
                       :little-endian))
     fixup-to-label)
    (prog1 (io->str bcode)
           (io-close bcode))))

(def (const-to-idx-vec e)
  (let ((cvec (vec-alloc (bcode:nconst e))))
    (for-each (λ (val idx) (aset! cvec idx val))
              (bcode:ctable e))
    cvec))

;; variables

(def (vinfo symbol heap? index) (list symbol heap? index))
(def vinfo:sym car)
(def vinfo:heap? cadr)
(def vinfo:index caddr)

(def (quoted? e)
  (eq? (car e) '$quote))

(def (capture-var! g s)
  (def (index-of item lst start)
    (cond ((not lst) NIL)
          ((eq? item (car lst)) start)
          (else (index-of item (cdr lst) (+ start 1)))))
  (let* {[ce (bcode:cenv g)]
         [n (index-of s ce 0)]}
    (or n
        (prog1 (length ce)
               (aset! g 3 (nconc ce (list s)))))))

(def (in-env? s env)
  (and (cons? env)
       (or (assq s (car env))
           (in-env? s (cdr env)))))

(def (lookup-sym s env lev)
  (if (not env)
      'global
      (let* ((curr (car env))
             (vi   (assq s curr)))
        (if vi
            (cons lev vi)
            (lookup-sym s
                        (cdr env)
                        (+ lev 1))))))

(def (compile-sym g env s deref)
  (def (printable? x)
    (not (or (io? x)
             (void? x)
             (eof? x))))
  (let ((loc (lookup-sym s env 0)))
    (cond ((eq? loc 'global)
           (if (and (const? s)
                    (printable? (top-level-value s))
                    (not (or (<= '*a s '*z) (<= '+a s '+z))))
               (emit g 'loadv (top-level-value s))
               (emit g 'loadg s)))

          ((= (car loc) 0)
           (emit g 'loada (vinfo:index (cdr loc)))
           (when (and deref (vinfo:heap? (cdr loc)))
             (emit g 'car)))

          (else
           (emit g 'loadc (capture-var! g s))
           (when (and deref (vinfo:heap? (cdr loc)))
             (emit g 'car))))))

(def (compile-aset! g env args)
  (let ((nref (- (length args) 2)))
    (cond ((= nref 1)
           (compile-app g env NIL (cons 'aset! args)))
          ((> nref 1)
           (compile-app g env NIL (cons 'aref (subseq args 0 nref)))
           (let ((nargs (compile-arglist g env (subseq args nref))))
                (bcode:stack g (- nargs))
                (emit g 'aset!)))
          (else (argc-error 'aset! 3)))))

(def (compile-set! g env s rhs (err-no-def NIL))
  (let ((loc (lookup-sym s env 0)))
    (if (eq? loc 'global)
        (begin (when (and err-no-def (not (bound? s)))
                 (compile-error "undefined variable: " s))
               (compile-in g env NIL rhs)
               (emit g 'setg s))
        (let* {[h? (vinfo:heap? (cdr loc))]
               [arg? (= (car loc) 0)]
               [idx (if arg?
                        (vinfo:index (cdr loc))
                        (capture-var! g s))]}
          (if h?
              (begin (emit g (if arg? 'loada 'loadc) idx)
                     (bcode:stack g 1)
                     (compile-in g env NIL rhs)
                     (bcode:stack g -1)
                     (emit g 'set-car!))
              (compile-in g env NIL rhs)
              (unless arg? (error (str "internal error: misallocated var " s)))
              (emit g 'seta idx))))))

(def (box-vars g env)
  (let loop ((e env))
    (when (cons? e)
      (when (cadr (car e))
        (emit g 'box (caddr (car e))))
      (loop (cdr e)))))

;; control flow

(def (compile-if g env tail? x)
  (let ((thenl (make-label g))
        (elsel (make-label g))
        (endl  (make-label g))
        (test  (cadr x))
        (then  (caddr x))
        (else  (if (cons? (cdddr x))
                   (cadddr x)
                   NIL)))
    (cond ((eq? test T)
           (compile-in g env tail? then))
          ((not test)
           (compile-in g env tail? else))
          (else
           (compile-in g env NIL test elsel)
           (emit g 'brn elsel)
           (mark-label g thenl)
           (compile-in g env tail? then)
           (if tail?
               (emit g 'ret)
               (emit g 'jmp endl))
           (mark-label g elsel)
           (compile-in g env tail? else)
           (mark-label g endl)))))

(def (compile-begin g env tail? forms)
  (cond ((atom? forms) (compile-in g env tail? #.(void)))
        ((atom? (cdr forms))
         (compile-in g env tail? (car forms)))
        (else
         (compile-in g env NIL (car forms))
         (emit g 'pop)
         (compile-begin g env tail? (cdr forms)))))

(def (compile-prog1 g env x)
  (compile-in g env NIL (cadr x))
  (when (cons? (cddr x))
    (bcode:stack g 1)
    (compile-begin g env NIL (cddr x))
    (emit g 'pop)
    (bcode:stack g -1)))

(def (compile-while g env cond body)
  (let ((top  (make-label g))
        (end  (make-label g)))
    (compile-in g env NIL #.(void))
    (bcode:stack g 1)
    (mark-label g top)
    (compile-in g env NIL cond)
    (emit g 'brn end)
    (emit g 'pop)
    (bcode:stack g -1)
    (compile-in g env NIL body)
    (emit g 'jmp top)
    (mark-label g end)))

(def (compile-short-circuit g env tail? forms default branch outl)
  (cond ((atom? forms)        (compile-in g env tail? default outl))
        ((atom? (cdr forms))  (compile-in g env tail? (car forms) outl))
        (else
         (let ((end (or outl (make-label g))))
           (compile-in g env NIL (car forms) outl)
           (bcode:stack g 1)
           (unless outl (emit g 'dup))
           (emit g branch end)
           (bcode:stack g -1)
           (unless outl (emit g 'pop))
           (compile-short-circuit g env tail? (cdr forms) default branch outl)
           (unless outl (mark-label g end))))))

(def (compile-and g env tail? forms outl)
  (compile-short-circuit g env tail? forms T 'brn outl))
(def (compile-or g env tail? forms)
  (compile-short-circuit g env tail? forms NIL 'brnn NIL))

;; calls

(def (compile-arglist g env lst)
  (for-each (λ (a)
              (compile-in g env NIL a)
              (bcode:stack g 1))
            lst)
  (length lst))

(def (argc-error head count)
  (compile-error head " expects " count (if (= count 1)
                                            " argument."
                                            " arguments.")))

(def builtin->instruction
  (let ((b2i (table num? 'num?  cons 'cons
                    fixnum? 'fixnum?  equal? 'equal?
                    eq? 'eq?  sym? 'sym?
                    div0 'div0  builtin? 'builtin?
                    aset! 'aset!  - '-  not 'not
                    apply 'apply  atom? 'atom? nan? 'nan?
                    set-cdr! 'set-cdr!  / '/
                    fn? 'fn?  vec 'vec
                    list 'list  bound? 'bound?
                    < '<  * '* cdr 'cdr cadr 'cadr
                    + '+  eqv? 'eqv? compare 'compare  aref 'aref
                    set-car! 'set-car!  car 'car
                    cons? 'cons?  = '=  vec? 'vec?)))
    (λ (b)
      (get b2i b NIL))))

(def (compile-builtin-call g env tail? x head b nargs)
  (def (num-compare)
    (if (= nargs 0)
        (argc-error b 1)
        (emit g b nargs)))
  (let ((count (get arg-counts b NIL)))
    (when (and count (not (length= (cdr x) count)))
      (argc-error b count))
    (case b  ; handle special cases of vararg builtins
      (list (if (= nargs 0)
                (emit g 'loade8 #.(logior 1 (ash 1 3))) ; NIL
                (emit g b nargs)))
      (<    (num-compare))
      (=    (num-compare))
      (+    (cond ((= nargs 0) (emit g 'load0))
                  ((= nargs 2) (emit g 'add2))
                  (else (emit g b nargs))))
      (-    (cond ((= nargs 0) (argc-error b 1))
                  ((= nargs 1) (emit g 'neg))
                  ((= nargs 2) (emit g 'sub2))
                  (else (emit g b nargs))))
      (*    (if (= nargs 0)
                (emit g 'load1)
                (emit g b nargs)))
      (/    (if (= nargs 0)
                (argc-error b 1)
                (emit g b nargs)))
      (vec      (if (= nargs 0)
                    (emit g 'loadv #())
                    (emit g b nargs)))
      (apply    (if (< nargs 2)
                    (argc-error b 2)
                    (emit g (if tail? 'tapply 'apply) nargs)))
      (aref     (cond ((= nargs 2) (emit g 'aref2))
                      ((> nargs 2) (emit g b (- nargs 3)))
                      (else (argc-error b 2))))
      (else     (emit g b)))))

(def (inlineable? form)
  (let ((lam (car form)))
    (and (cons? lam)
         (eq? (car lam) 'λ)
         (proper-list? (cadr lam))
         (every sym? (cadr lam))
         (not (length> (cadr lam) 255))
         (length= (cadr lam) (length (cdr form))))))

;; compile call to lambda in head position, inlined
(def (compile-let g env tail? form)
  (let ((lam  (car form))
        (args (cdr form))
        (sp   (bcode:sp g)))
    (let ((vars (cadr lam))
          (n    (compile-arglist g env args)))
      (let ((newvars
             (vars-to-env vars (complex-bindings (caddr lam) vars) sp)))
        (box-vars g newvars)
        (let ((newenv
               (cons (nconc newvars (car env))
                     (cdr env))))
          (compile-in g newenv tail? (caddr lam))
          (bcode:stack g (- n))
          (when (and (> n 0) (not tail?))
            (emit g 'shift n)))))))

(def (compile-app g env tail? x)
  (let* {[head (car x)]
         [head (if (and (sym? head)
                        (not (in-env? head env))
                        (bound? head)
                        (builtin? (top-level-value head)))
                   (top-level-value head)
                   head)]
         [b (and (builtin? head)
                 (builtin->instruction head))]}
    (if (length> (cdr x) 255)
        ;; more than 255 arguments, need long versions of instructions
        (begin (compile-in g env NIL head)
               (bcode:stack g 1)
               (let ((nargs (compile-arglist g env (cdr x))))
                 (bcode:stack g (- nargs))
                 (emit g (if tail? 'tcall.l 'call.l) nargs)))
        (if (and (cons? head)
                 (eq? (car head) 'λ)
                 (inlineable? x))
            (compile-let g env tail? x)
            (if b
                (begin (let {[nargs (compile-arglist g env (cdr x))]}
                         (bcode:stack g (- nargs))
                         (compile-builtin-call g env tail? x head b nargs)))
                (compile-in g env NIL head)
                (bcode:stack g 1)
                (let* {[nargs (compile-arglist g env (cdr x))]
                       [loc (and (sym? head) (lookup-sym head env 0))]
                       [fn (and (eq? loc 'global) (bound? head) (top-level-value head))]
                       [code (and (closure? fn) (fn-code fn))]
                       [argc? (and code (= (aref code 0) (get Instructions 'argc)))]
                       [argc (and argc? (aref code 1))]}
                  (unless (or (not argc) (= argc nargs))
                    (compile-error "arity error: expected " argc ", got " nargs))
                  (bcode:stack g (- nargs))
                  (bcode:stack g -1)
                  (emit g (if tail? 'tcall 'call) nargs)))))))

;; lambda, main compilation loop

(def (compile-in g env tail? x (outl NIL))
  (def (fits-i8 x) (and (fixnum? x)
                        (>= 127 x -128)))
  (cond ((sym? x) (compile-sym g env x T))
        ((atom? x)
         (cond ((eq? x 0)   (emit g 'load0))
               ((eq? x 1)   (emit g 'load1))
               ((not x)     (emit g 'loade8 #.(logior 1 (ash 1 3)))) ; NIL
               ((eq? x T)   (emit g 'loade8 #.(logior 1 (ash 2 3)))) ; T
               ((void? x)   (emit g 'loade8 #.(logior 1 (ash 3 3)))) ; #<void>
               ((fits-i8 x) (emit g 'loadi8 x))
               (else        (emit g 'loadv x))))
        ((eq? (car x) 'aset!)
         (compile-aset! g env (cdr x)))
        ((or (not (sym? (car x))) (bound? (car x)) (in-env? (car x) env))
         (compile-app g env tail? x))
        ((or (eq? (car x) '$set!)
             (eq? (car x) '$set!-))
         (let {[name (cadr x)]
               [value (caddr x)]
               [nargs (length (cdr x))]}
           (unless (= nargs 2)
             (compile-error "set!: arity error: expected 2, got " nargs))
           (unless (sym? name)
             (type-error 'sym name "set!" "name"))
           (when (eq? name value)
             (compile-error "set!: useless assignment to itself"))
           (compile-set! g env name value (eq? (car x) '$set!))))
        (else
         (case (car x)
           ($quote   (if (self-evaluating? (cadr x))
                         (compile-in g env tail? (cadr x))
                         (emit g 'loadv (cadr x))))
           ($if      (compile-if g env tail? x))
           ($begin   (compile-begin g env tail? (cdr x)))
           ($prog1   (compile-prog1 g env x))
           (λ        (receive (the-f cenv) (compile-f- env x)
                       (begin (emit g 'loadv the-f)
                              (when cenv
                                (for-each (λ (var)
                                            (compile-sym g env var NIL))
                                          cenv)
                                (emit g 'closure (length cenv))))))
           ($and     (compile-and g env tail? (cdr x) outl))
           ($or      (compile-or  g env tail? (cdr x)))
           ($while   (compile-while g env (cadr x) (cons '$begin (cddr x))))
           ($return  (compile-in g env T (if (cons? (cdr x))
                                             (cadr x)
                                             #.(void)))
                     (emit g 'ret))
           ($trycatch (compile-in g env NIL `(λ () ,(cadr x)))
                      (compile-in g env NIL (caddr x))
                      (emit g 'trycatch))
           (else   (compile-app g env tail? x))))))

;; optional and keyword args

(def (lambda-vars l)
  (def (keyword->sym k)
    (if (keyword? k)
        (sym (let ((s (str k)))
               (str-sub s 1)))
        k))
  (def (check-formals l o opt kw)
    (cond ((or (not l) (and (sym? l) (not (keyword? l)))) T)
          ((and (cons? l) (and (sym? (car l)) (not (keyword? (car l)))))
           (if (or opt kw)
               (compile-error "invalid argument list "
                      o ": optional arguments must come after required")
               (check-formals (cdr l) o opt kw)))
          ((and (cons? l) (cons? (car l)))
           (unless (and (sym? (caar l))
                        (or (length= (car l) 2) ; default value
                            (and (length= (car l) 3) ; default value and "var-supplied"
                                 (sym? (caddar l)))))
                   (compile-error "invalid optional argument " (car l)
                          " in list " o))
           (if (keyword? (caar l))
               (check-formals (cdr l) o opt T)
               (if kw
                   (compile-error "invalid argument list "
                          o ": keyword arguments must come last.")
                   (check-formals (cdr l) o T kw))))
          ((cons? l)
           (compile-error "invalid formal argument " (car l)
                  " in list " o))
          (else
           (if (eq? l o)
               (compile-error "invalid argument list " o)
               (compile-error "invalid formal argument " l
                      " in list " o)))))
  (check-formals l l NIL NIL)
  (map (λ (s) (if (cons? s) (keyword->sym (car s)) s))
        (to-proper l)))

(def (emit-optional-arg-inits g env opta vars i)
  ; i is the lexical var index of the opt arg to process next
  (when (cons? opta)
    (let ((nxt (make-label g)))
      (emit g 'bounda i)
      (when (cddar opta)
        (emit g 'dup))
      (emit g 'brnn nxt)
      (compile-in g (extend-env env (subseq vars 0 i) NIL) NIL (cadar opta))
      (emit g 'seta i)
      (emit g 'pop)
      (mark-label g nxt)
      (emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))

;; def

(def (expand-def x)
  ;; expand a single `def` expression to `set!`
  (let* ((form (cadr x))
         (body (if (cons? (cddr x))
                   (cddr x)
                   (if (sym? form)
                       #.void
                       (compile-error "invalid syntax " (print-to-str x))))))
    (if (sym? form)
        `($set!- ,form ,(car body))
        `($set!- ,(car form)
                 (λ ,(cdr form) ,.body ,.(car form))))))

(def (get-defined-vars expr)
  (letrec ((get-defined-vars-
            (λ (expr)
              (cond ((atom? expr) NIL)
                    ((and (eq? (car expr) '$def)
                          (cons? (cdr expr)))
                     (or (and (sym? (cadr expr))
                              (list (cadr expr)))
                         (and (cons? (cadr expr))
                              (sym? (caadr expr))
                              (list (caadr expr)))))
                    ((eq? (car expr) '$begin)
                     (apply nconc (map get-defined-vars- (cdr expr))))
                    (else NIL)))))
    (remove-duplicates (get-defined-vars- expr))))

(def (lower-def e (top NIL))
  ;; convert lambda to one body expression and process internal defines
  (def (λ-body e)
    (let* ((B (if (cons? (cddr e))
                  (if (cons? (cdddr e))
                      (cons '$begin (cddr e))
                      (caddr e))
                  #.(void)))
           (V (get-defined-vars B))
           (new-B (lower-def B)))
      (if V
          (cons `(λ ,V ,new-B)
                (map void V))
          new-B)))
  (cond ((or (atom? e) (quoted? e))
         e)
        ((eq? (car e) '$def)
         (if top
             `(#.void ,(lower-def (expand-def e)))
             (lower-def (expand-def e))))
        ((eq? (car e) 'λ)
         `(λ ,(cadr e) ,(λ-body e) ,.(last-cdr e)))
        (else
         (map lower-def e))))

;; closure analysis

(def (lambda:body e)
  (caddr e))

(def (lambda:vars e)
  (lambda-vars (cadr e)))

;; bindings that are both captured and set!'d
(def (complex-bindings- e vars head nested capt setd)
  (def (diff s1 s2)
    (cond ((not s1)           NIL)
          ((memq (car s1) s2) (diff (cdr s1) s2))
          (else               (cons (car s1) (diff (cdr s1) s2)))))
  (cond ((not vars) NIL)
        ((sym? e)
         (when (and nested (memq e vars))
           (put! capt e T)))
        ((or (atom? e) (quoted? e)) NIL)
        ((or (eq? (car e) '$set!) (eq? (car e) '$set!-))
         (when (memq (cadr e) vars)
           (put! setd (cadr e) T)
           (when nested (put! capt (cadr e) T)))
         (complex-bindings- (caddr e) vars NIL nested capt setd))
        ((eq? (car e) 'λ)
         (complex-bindings- (lambda:body e)
                            (diff vars (lambda:vars e))
                            NIL
                            (or (not head) nested)
                            capt setd))
        (else
         (cons (complex-bindings- (car e) vars (inlineable? e) nested capt setd)
               (map (λ (x)
                      (complex-bindings- x vars NIL nested capt setd))
                    (cdr e))))))

(def (complex-bindings e vars)
  (let ((capt (table))
        (setd (table)))
    (complex-bindings- e vars NIL NIL capt setd)
    (filter (λ (x) (has? capt x))
            (table-keys setd))))

(def (vars-to-env vars cb offs)
  (map (λ (var i) (vinfo var (not (not (memq var cb))) (+ i offs)))
       vars (iota (length vars))))

(def (extend-env env vars cb)
  (cons (vars-to-env vars cb 0)
         env))

;; main entry points

(def (compile f)
  (compile-f NIL (lower-def f *interactive*)))

(def (compile-thunk expr)
  ;; to eval a top-level expression we need to avoid internal define
  (compile-f NIL `(λ () ,(lower-def expr *interactive*))))

(def (compile-f env f)
  (receive (ff ignore)
           (compile-f- env f)
           ff))

(def (compile-f- env f)
  (def (any-duplicates v)
    (let ((k (car v))
          (rest (cdr v)))
      (when rest
        (or (any (λ (next) (and (eq? k next) k)) rest)
            (any-duplicates rest)))))
  (def (keyword-arg? x)
    (and (cons? x) (keyword? (car x))))
  (def (novar lst)
    (and (cons? lst)
         (cons (car lst) (novar (cdr lst)))))

  ;; compile lambda expression, assuming defines already lowered
  (let* ((g     (make-code-emitter))
         (args  (cadr f))
         (atail (last-cdr args))
         (novar (if atail (novar args) args))
         (vars  (lambda:vars f))
         (opta  (filter cons? novar))
         (suppl (map caddr (filter cddr opta)))
         (last  (last-cdr f))
         (name  (if (not last) 'λ last))
         (nargs (if (atom? novar) 0 (length novar)))
         (nreq  (- nargs (length opta)))
         (kwa   (filter keyword-arg? opta))
         (nkwa  (length kwa))
         (dupv  (any-duplicates vars)))

    (when dupv
      (compile-error "duplicate argument: " dupv))

    ;; emit argument checking prologue
    (when opta
      (if (not kwa)
          (emit g 'optargs nreq
                (if atail (- nargs) nargs))
          (bcode:indexfor g (map 'vec car kwa))
          (emit g 'keyargs nreq nkwa
                (if atail (- nargs) nargs))))

    (cond ((> nargs 255) (emit g (if atail 'vargc.l 'argc.l) nargs))
          (atail         (emit g 'vargc nargs))
          ((not opta)    (emit g 'argc  nargs)))

    (when opta
      (emit-optional-arg-inits g env opta vars nreq))

    (let* {[args vars]
           [bpvars (if suppl ; "supplied?" are placed at the current frame start
                       (append vars '(NIL NIL NIL NIL) suppl)
                       vars)]
           [vars (if suppl (append vars suppl) vars)]
           [newenv (extend-env env bpvars (complex-bindings (lambda:body f) vars))]}
      (box-vars g (car newenv))
      ;; set initial stack pointer
      (bcode:stack g (+ (length vars) 4))
      ;; compile body and return
      (compile-in g newenv T (lambda:body f))
      (emit g 'ret)
      (values (fn (encode-byte-code (bcode:code g))
                  (const-to-idx-vec g)
                  name
                  (- (bcode:spmax g) (length args))
                  T)
              (bcode:cenv g)))))

;; disassembler

(def (fn-disasm f (:ip NIL) (:readable T) (:level NIL))
  (def (ref-s32-LE a i)
    (s32 (+ (ash (aref a (+ i 0)) 0)
            (ash (aref a (+ i 1)) 8)
            (ash (aref a (+ i 2)) 16)
            (ash (aref a (+ i 3)) 24))))
  (def (ref-s16-LE a i)
    (s16 (+ (ash (aref a (+ i 0)) 0)
            (ash (aref a (+ i 1)) 8))))
  (def (hex5 n)
    (str-pad (num->str n :base 16) 5 :align :right :fill #\0))
  (def readable-tbl #table(
    add2 "add 2" aref2 "aref 2" argc.l argc box.l box
    brn.l brn brne.l brne brnn.l brnn call.l call
    jmp.l jmp load0 "loadi8 0" load1 "loadi8 1"
    loada.l loada loadc.l loadc loadg.l loadg
    loadv.l loadv seta.l seta
    setg.l setg sub2 "sub 2" tcall.l tcall vargc.l vargc))
  (when (builtin? f)
    (princ " > " ip " // PC")
    (return (newline)))
  (when (not level)
    (fn-disasm f :ip ip :readable readable :level 0)
    (return (newline)))
  (let ((code (fn-code f))
        (vals (fn-vals f)))
    (def (print-val v)
      (if (and (fn? v) (not (builtin? v)))
          (begin (newline)
                 (fn-disasm v :ip NIL :readable readable :level (+ level 1)))
          (print v)))
    (def (print-inst inst s sz)
      (princ (if (and ip (= level 0) (>= ip (1- s)) (< ip (+ s sz)))
                 " >"
                 "  ")
             (hex5 (- s 1)) ":  "
             (if readable
                 (get readable-tbl inst inst)
                 inst)
             " "))
    (let ((i 0)
          (N (size-of code)))
      (while (< i N)
             ; find key whose value matches the current byte
             (let ((inst (table-fold (λ (k v z)
                                        (or z (and (= v (aref code i))
                                                   k)))
                                      NIL Instructions)))
               (when (> i 0) (newline))
               (dotimes (xx level) (princ "\t"))
               (set! i (+ i 1))
               (case inst
                 ((loadv.l loadg.l setg.l)
                  (print-inst inst i 4)
                  (print-val (aref vals (ref-s32-LE code i)))
                  (set! i (+ i 4)))

                 ((loadv loadg setg)
                  (print-inst inst i 1)
                  (print-val (aref vals (aref code i)))
                  (set! i (+ i 1)))

                 (loade8
                  (print-inst inst i 1)
                  (princ (case (aref code i)
                           (#.(logior 1 (ash 1 3)) NIL)
                           (#.(logior 1 (ash 2 3)) T)
                           (#.(logior 1 (ash 3 3)) #.(void))))
                  (set! i (+ i 1)))

                 ((loada seta loadc call tcall list + - * / < = vec
                   argc vargc apply tapply closure box shift aref)
                  (print-inst inst i 1)
                  (princ (+ (aref code i) (if (eq? inst 'aref) 3 0)))
                  (set! i (+ i 1)))

                 (loadi8
                  (print-inst inst i 1)
                  (princ (s8 (aref code i)))
                  (set! i (+ i 1)))

                 ((loada.l seta.l loadc.l argc.l vargc.l call.l tcall.l box.l)
                  (print-inst inst i 4)
                  (princ (ref-s32-LE code i))
                  (set! i (+ i 4)))

                 ((optargs keyargs)
                  (print-inst inst i (+ 8 (if (eq? inst 'keyargs) 4 0)))
                  (princ (ref-s32-LE code i) " ")
                  (set! i (+ i 4))
                  (princ (ref-s32-LE code i))
                  (set! i (+ i 4))
                  (when (eq? inst 'keyargs)
                    (princ " ")
                    (princ (ref-s32-LE code i) " ")
                    (set! i (+ i 4))))

                 ((bounda)
                  (print-inst inst i 4)
                  (princ (ref-s32-LE code i) " ")
                  (set! i (+ i 4)))

                 ((jmp brne brnn brn)
                  (print-inst inst i 2)
                  (princ "@" (hex5 (+ i (ref-s16-LE code i))))
                  (set! i (+ i 2)))

                 ((jmp.l brne.l brnn.l brn.l)
                  (print-inst inst i 4)
                  (princ "@" (hex5 (+ i (ref-s32-LE code i))))
                  (set! i (+ i 4)))

                 (else (print-inst inst i 0))))))))