;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

(use goo)
(use goo/boot)
(use eval/syntax)
(use eval/ast)
(use eval/top)
(use eval/ast-linearize)
(use eval/optimize)
(use eval/typist)
(use eval/vm)

;;;; TODO
;;;; 
;;;; module dumping
;;;; less consing on emission
;;;; perhaps do framing on the fly
;;;; print vars module by module
;;;; source locations
;;;; 

(dm frame! (o)
  (frame-mets! o #f 1))

(dm frame-mets! (o|<program> met index)
  (ast-walk frame-mets! o met index))

(dm frame-mets! (o|<ast-method> met index)
  (set (function-frame-len o) 1)
  (frame-mets! (function-body o) o 1))

(dm frame-mets! (o|<fix-let> met index)
  (rep assign ((bindings (enum (fix-let-bindings o))) (index index))
    (if (fin? bindings)
        (seq (when (> index (function-frame-len met))
               (set (function-frame-len met) index))
             (frame-mets! (fix-let-arguments o) met index)
             (frame-mets! (fix-let-types o) met index)
             (frame-mets! (fix-let-body o) met index))
        (seq (set (binding-index (now bindings)) index)
             (assign (nxt bindings) (+ index 1))))))

(dm frame-mets! (o|<locals> met index)
  (rep assign ((bindings  (enum (locals-bindings o)))
               (functions (enum (locals-functions o)))
               (index     index))
    (if (fin? bindings)
        (seq (when (> index (function-frame-len met))
               (set (function-frame-len met) index))
             (frame-mets! (locals-body o) met index))
        (seq (set (binding-index (now bindings)) index)
             (frame-mets! (now functions) met 1)
             (assign (nxt bindings) (nxt functions) (+ index 1))))))

(dm asm-closurize-main! (o|<program> r)
  (loc ((fab-nul-method (name body)
          (def sig (objectify-signature '() r))
          (new <ast-method>
            function-debug-name (objectify-quotation name 4)
            function-signature  sig
            function-body       body)))
    (def name     (cat-sym "_main_"))
    (def main-met (fab-nul-method name o))
    (def call
        (new <regular-application> 
          application-function  main-met
          application-arguments (nul <arguments>)
          application-tail?     #f))
    call))

;;; DRIVER

(dm asm-compute-program (exp env)
  (def ast (objectify-with-subtransaction exp env #f #f))
  (def ana (analyze-calls ast env))
  (def box (insert-box! ana))
  (def lft (lift! box))
  (def top (asm-closurize-main! lft env))
  (frame! top)
  top)

(dv <ord-tab> <tab>)

(dc <g2m> (<any>))
  (dp  g2m-vars    (<g2m> => <ord-tab>) (fab <ord-tab> 0))
  (dp  g2m-lits    (<g2m> => <ord-tab>) (fab <ord-tab> 0))
  (dp! g2m-nxt-lab (<g2m> => <int>)     -1)

(dm asm-exp-in (e env)
  (def g2m (new <g2m>))
  (asm-all g2m (asm-compute-program e env)))

(dm asm-exp (e)
  (asm-exp-in e (runtime-environment 'eval/vm)))

(dm nxt-lab (x|<g2m> => <sym>)
  (cat-sym "L" (incf (g2m-nxt-lab x))))

(dm ord-tab-to-seq (x|<ord-tab> => <lst>)
  (def v (fab <vec> (len x)))
  (for (((tup y i) x)) (set (elt v i) y))
  (as <lst> v))

(dm asm-all (x|<g2m> p|<program>)
  (def ops (asm x p #t))
  (loc ((var-path (b) (lst (binding-module-name b) (binding-name b))))
    (lst (ord-tab-to-seq (g2m-lits x))
         (map var-path (ord-tab-to-seq (g2m-vars x)))
         ops)))

(dm out-code (out code)
  (msg out "(%=\n" (1st code))
  (msg out " %=\n (\n" (2nd code))
  (do (fun (e) (msg out "  %=\n" e)) (3rd code))
  (msg out "))\n"))

;;; EMISSION

(dv <code> <lst>)

;; STATEMENTS

(dm asm-need (need?|<log> x|<code> => <code>)
  (if need?
      x
      (tack x '((VM-POP)))))

(dm asm-if (need?|<log> x|<code> => <code>)
  (if need? x '()))

(dg asm (x|<g2m> e|<program> need?|<log>))

(dm asm (x|<g2m> e|<passive-program> need?|<log>) '())

(dm asm (x|<g2m> e|<free-reference> need?|<log>)
  (asm-if need? `((VM-ENV-GET ,(+ (reference-offset e) 1)))))

(dv tack cat)

(dm tack+need (need?|<log> codes|... => <code>)
  (asm-need need? (app tack codes)))

(dm get-var-ref (x|<g2m> e|<any> => <int>)
  (def vars (g2m-vars x))
  (or (elt-or vars e #f) (set (elt vars e) (len vars))))

(dm asm (x|<g2m> e|<module-binding-reference> need?|<log>)
  (def idx (get-var-ref x (reference-binding e)))
  (asm-if need? `((VM-VAR-GET ,idx))))

(dm get-lit-ref (x|<g2m> e|<any> => <int>)
  (def lits (g2m-lits x))
  (or (elt-or lits e #f) (set (elt lits e) (len lits))))

(dm asm (x|<g2m> e|<constant> need?|<log>)
  (def idx (get-lit-ref x (constant-value e)))
  (asm-if need? `((VM-LIT ,idx))))

(dm asm (x|<g2m> e|<global-assignment> need?|<log>)
  (def idx (get-var-ref x (assignment-binding e)))
  (tack+need need? (asm x (assignment-form e) #t) `((VM-VAR-PUT ,idx))))

(dm asm (x|<g2m> e|<definition> need?|<log>)
  (def idx (get-var-ref x (assignment-binding e)))
  (tack `((VM-VAR-FAB ,idx)) (sup x e need?)))

(dm asm (x|<g2m> e|<bound?> need?|<log>)
  (def idx (get-var-ref x (reference-binding (bound?-reference e))))
  (tack+need need? 
    (asm x (bound?-default e) #t)
    `((VM-VAR-GET-OR ,idx))))

(dm asm (x|<g2m> e|<reference> need?|<log>)
  (asm-if need? `((VM-LOC-GET ,(binding-index (reference-binding e))))))

(dm asm (x|<g2m> e|<box-read> need?|<log>)
  (def ref (box-reference e))
  (tack+need need?
   (asm x ref #t)
   (if (binding-closed-over? (reference-binding ref)) `((VM-BOX-GET)) '())))

(dm asm (x|<g2m> e|<box-write> need?|<log>)
  (def ref (box-reference e))
  (def var (reference-binding ref))
  (if (binding-closed-over? var)
      (tack+need need?
        (asm x ref #t)
        (asm x (box-form e) #t)
        `((VM-BOX-PUT)))
      (tack (asm x (box-form e) #t)
            `((VM-LOC-PUT ,(binding-index var)))
            (if need? `((VM-LOC-GET ,(binding-index var))) '()))))

(dm asm (x|<g2m> e|<box-creation> need?|<log>)
  (def binding (reference-binding (box-reference (box-reference e))))
  (if (binding-closed-over? binding)
      `((VM-BOX-FAB ,(binding-index binding)))
      '()))

(dm asm (x|<g2m> e|<alternative> need?|<log>)
  (def l1 (nxt-lab x))
  (def l2 (nxt-lab x))
  (tack (asm x (alternative-condition e) #t)
        `((VM-JMP-NOT ,l1))
        (asm x (alternative-consequent e) need?)
        `((VM-JMP ,l2))
        `(,l1)
        (asm x (alternative-alternant e) need?)
        `(,l2)))

(dm flatten (args|<code> => <code>) 
  (fold tack (nul <code>) args))

(dm asm (x|<g2m> e|<arguments> need?|<log>)
  (flatten (as <lst> (map (fun (y) (asm x y #t)) e))))

(dm asm (x|<g2m> e|<free-environment> need?|<log>)
  (flatten (as <lst> (map (fun (y) (asm x y #t)) e))))

(dm asm (x|<g2m> e|<sequential> need?|<log>)
  (rep emit ((res '()) (e e))
    (if (nul? (tail e))
        (flatten (rev! (pair (asm x (head e) need?) res)))
        (emit (pair (asm x (head e) #f) res) (tail e)))))

(dm asm (x|<g2m> e|<loop> need?|<log>)
  (def lab (nxt-lab x))
  (set (loop-continue e) lab)
  (tack `(,lab)
        (asm x (loop-body e) need?)))

(dm asm (x|<g2m> e|<loop-application> need?|<log>)
  (def loop (application-loop e))
  (tack (asm x (application-arguments e) #t)
        (map (fun (b) `(VM-LOC-PUT ,(binding-index b))) 
             (rev (loop-bindings loop)))
        `((VM-JMP ,(loop-continue loop)))))

(dm asm (x|<g2m> e|<regular-application> need?|<log>)
  (tack (asm x (application-function e) #t)
        (asm x (application-arguments e) #t)
        (asm-need need? 
          `((,(if (application-tail? e) 'VM-APP-JMP 'VM-APP)
             ,(len (application-arguments e)))))))

(dm asm (x|<g2m> e|<predefined-application> need?|<log>)
  (def b (application-binding e))
  (case (binding-name b) 
    (('%next-methods) `((VM-NXT-METS)))
    (('%fun-reg)      `((VM-FUN)))
    (#t                (error "UNKNOWN PREDEFINED %= IN VM" (binding-name b)))))

(dm asm (x|<g2m> e|<fix-let> need?|<log>)
  (tack (flatten
          (packing ()
            (for ((binding (fix-let-bindings e)) (type (fix-let-types e))
                  (init (fix-let-arguments e)))
              (pack (asm x init #t))
              (unless (or (not type) (unconstrained-type? type))
                (pack `((VM-DUP)))
                (pack (asm x type #t))
                (pack `((VM-TYP-CHK))))
              (pack `((VM-LOC-PUT ,(binding-index binding)))))))
        (asm x (fix-let-body e) need?)))

(dm asm (x|<g2m> e|<bind-exit> need?|<log>)
  (tack (asm x (bind-exit-main-fun e) #t)
        (asm-need need? `((VM-ESC)))))

(dm asm (x|<g2m> e|<unwind-protect> need?|<log>)
  (tack (asm x (unwind-protect-protected-thunk e) #t)
        (asm x (unwind-protect-cleanup-thunk e) #t)
        (asm-need need? `((VM-FIN)))))

(dm asm (x|<g2m> e|<monitor> need?|<log>)
  (tack (asm x (monitor-type e) #t)
        (asm x (monitor-info e) #t)
        (asm x (monitor-test e) #t)
        (asm x (monitor-handler e) #t)
        (asm x (monitor-main-thunk e) #t)
        (asm-need need? `((VM-TRY)))))

(dm asm-fun (x|<g2m> e|<ast-method> fab-op|<sym> need?|<log>)
  (for ((bnd (function-bindings e)) (i (from 1)))
    (set (binding-index bnd) (neg i)))
  (def l1 (nxt-lab x))
  (def l2 (nxt-lab x))
  (def n  (len (function-free e)))
  (tack (asm x (function-free e) #t)
        `((,fab-op ,n ,l1))
        `((VM-JMP ,l2))
        `(,l1)
        `((VM-ENV-LNK ,(- (function-frame-len e) 1)) ;; TODO: MAX INDEX 
          ,@(asm x (function-body e) #t)
          ,@(if (unconstrained-type? (function-value e)) 
                `((VM-RET))
                `((VM-RET-CHK))))
        `(,l2)))

(dm asm-fun-shell (x|<g2m> e|<ast-function> need?|<log>)
  (tack (asm x (function-signature e)  #t)
        (asm x (function-debug-name e) #t) 
        (asm x (function-names e) #t) 
        ))
                               
(dm asm (x|<g2m> e|<ast-method> need?|<log>)
  (tack (asm-fun-shell x e need?)
        (asm-fun x e 'VM-FUN-FAB+INI need?)))

(dm asm (x|<g2m> e|<ast-signature> need?|<log>)
  (tack (flatten (map (fun (y) (asm x y #t)) (req-sig-specs e)))
        (asm x (signature-value e) #t)
        (asm-need need?
         `((VM-SIG-FAB 
            ,(constant-value (signature-arity e))
            ,(if (constant-value (signature-nary? e)) 1 0))))))

(dm asm (x|<g2m> e|<ast-generic> need?|<log>)
  (tack (asm-fun-shell x e need?)
        (asm-need need? `((VM-GEN-FAB)))))

(dm asm (x|<g2m> e|<locals> need?|<log>)
  (tack (flatten (map2 (fun (b f)
                         (def dyn? (binding-dynamic-extent? b))
                         (tack (asm-fun-shell x f need?)
                               `((,(if dyn? 'VM-FUN-FAB-DYN 'VM-FUN-FAB)))
                               `((VM-LOC-PUT ,(binding-index b)))))
                       (locals-bindings e) (locals-functions e)))
        (flatten (map2 (fun (b f) 
                         (tack `((VM-LOC-GET ,(binding-index b)))
                               (asm-fun x f 'VM-FUN-INI #t)))
                       (locals-bindings e) (locals-functions e)))
        (asm x (locals-body e) need?)))

(dm asm (x|<g2m> e|<ast-macro-definition> need?|<log>)
  (def idx (get-var-ref x (assignment-binding e)))
  (tack (asm x (assignment-form e) #f)
        `((VM-MAC-FAB ,idx))))

(export
  asm-exp
  asm-exp-in
  )

#/
(set goo/io/write:*max-print-length*  100)
(set goo/io/write:*max-print-depth*  8)
/#
