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

(use goo)
(use goo/boot)
(use goo/fun)
(use goo/io/write)
(use eval/ast)
(use eval/ast-eval)
(use eval/top)

;;;; TODO
;;;; 
;;;; module loading
;;;; dynamic variables
;;;; ---
;;;; stack per thread
;;;; preconvert code to have functions OR use bytes
;;;; code vec per met
;;;; ---
;;;; use underlying g2c stack
;;;; customize instructions
;;;;   thunk
;;;;   <any>/req only sig
;;;; convert to more efficient implementation
;;;; source locators
;;;; 

(dv *depth*  0)
(dv *trace?* #f)
(df trace (msg|<str> args|...)
  (when *trace?* (app post msg args)))

;;;; VM STATE

(dv $max-stk-len 1000)
(dv *stk*        (fab <vec> $max-stk-len))
(dv *code*       (fab <vec> 0))
(dv *exit*       #f) ;; USE FOR VM-TOP-RUN ESC'S

;;;; THE VM STATE

;; NOW STORED IN LOW-LEVEL MACHINE-STATE
;; (dv *sp*         0)
;; (dv *fp*         0)
;; (dv *fn*         #f)
;; (dv *pc*         0)

;;;; STACK

(df trace-stk (msg|<str>)
  (when *trace?* 
    (post "[%s" msg)
    (for ((i (range-by (- (%vsp) 1) >= 0 1-)))
      (when (= i (%vfp))
        (post " FP>"))
      (post " %=" [*stk* i]))
    (post "]")))

(dm vm-push (x) 
  (set [*stk* (%vsp)] x)
  (incf (%vsp))
  (trace-stk "PU")
  x)

(dm vm-pop (=> <any>) 
  (trace-stk "PO")
  (decf (%vsp))
  (def x [*stk* (%vsp)])
  x)

(dm vm-n-pop (n|<int> => <lst>) 
  (rep pop ((res '()) (i 0))
    (if (= i n)
        res
        (pop (pair (vm-pop) res) (+ i 1)))))

(df vm-env-lnk (n)
  (vm-push (%vfp))
  (set (%vfp) (- (%vsp) 1))
  (incf (%vsp) n))

(df vm-env-unlnk ()
  (set (%vsp) (%vfp))
  (set (%vfp) [*stk* (%vfp)])
  (trace-stk "UL"))

;;;; INSTRUCTION DEFINITION MACHINERY

(dv *opcodes* (fab <tab> 0))
(dv *codes*   (fab <vec> 256))
(dv *oplens*  (fab <vec> 256))
(dv *opnames* (fab <vec> 256))

(dv $vm-ret  0)

(df vm-nxt-op () 
  (def op [*code* (%vpc)])
  (incf (%vpc))
  op)

(ds def-vm-op (,name (,@args) ,opcode ,@body)
  (let ((defs (map (fun (arg) `(def ,arg (vm-nxt-op))) args)))
    `(loc ((op () ,@defs 
            (trace "OP %= %= " ',name (lst ,@args))
            (def _val_ (seq ,@body))
            (trace "-> %=\n" _val_)
            _val_))
       (set [*opcodes* ',name]  ,opcode)
       (set [*codes*   ,opcode] op)
       (set [*oplens*  ,opcode] ,(len args))
       (set [*opnames* ,opcode] ',name))))

(ds def-vm-push-op (,name (,@args) ,opcode ,@body)
  `(def-vm-op ,name (,@args) ,opcode (vm-push (seq ,@body))))

;;;; INSTRUCTIONS

(def-vm-push-op VM-DUP () 0
  [*stk* (1- (%vsp))])

(def-vm-op VM-POP () 1
  (vm-pop))

(def-vm-op VM-EXIT () 2
  (*exit* (vm-pop)))

(def-vm-push-op VM-LIT (x) 10
  x)

(def-vm-op VM-VAR-FAB (x) 20
  #f)

(def-vm-push-op VM-VAR-GET (x) 21
  (%binding-value-of x))

(def-vm-push-op VM-VAR-PUT (x) 22
  (set (%binding-value-of x) (vm-pop)))

(def-vm-push-op VM-VAR-GET-OR (x) 23
  (%binding-value-or-of x (vm-pop)))

(def-vm-op VM-MAC-FAB (x) 24
  (%%%macro x (vm-pop)))

(def-vm-push-op VM-LOC-GET (x) 30
  [*stk* (+ (%vfp) x)])

(def-vm-op VM-LOC-PUT (x) 31
  (set [*stk* (+ (%vfp) x)] (vm-pop)))

(def-vm-push-op VM-BOX-GET () 40
  (def box (vm-pop))              
  (assert (isa? box <box>) "NOT A BOX %=" box)
  (%vm-box-val box))

(def-vm-push-op VM-BOX-PUT () 41
  (def val (vm-pop))
  (def box (vm-pop))
  (assert (isa? box <box>) "NOT A BOX %=" box)
  (set (%vm-box-val box) val))

(def-vm-op VM-BOX-FAB (x) 42
  (def idx (+ (%vfp) x))              
  (set [*stk* idx] (%vm-box-fab [*stk* idx])))

(def-vm-push-op VM-ENV-GET (x) 50
  (%vm-fun-env-elt (%vfn) (%iu x)))

(def-vm-push-op VM-NXT-METS () 51
  (%vnm))

(def-vm-push-op VM-FUN () 52
  (%vfn))

(def-vm-push-op VM-TYP-CHK () 60
  (def t (vm-pop))
  (def x (vm-pop))
  (if (isa? x t) x (error "TYPE CHECK FAILURE %= NOTA %t" x t)))

(def-vm-op VM-JMP (n) 70
  (incf (%vpc) n))

(def-vm-op VM-JMP-NOT (n) 71
  (unless (vm-pop) (incf (%vpc) n)))

(df vm-app-imp (n)
  (def args (vm-n-pop n))
  (def nfn  (vm-pop))
  (def val  #f)
  (def opc  (%vpc))
  (def ofn  (%vfn))
  (def onm  (%vnm))
  (trace "SAVING @ %=\n" (%vpc)) 
  (dlet ((*depth* (+ *depth* 1)))
    (set val (app nfn args)))
  (set (%vfn) ofn)
  (set (%vnm) onm)
  (trace "RESUMING @ %=\n" opc) 
  (set (%vpc) opc)
  val)

(def-vm-push-op VM-APP (n) 80
  (vm-app-imp n))
                
(def-vm-push-op VM-APP-JMP (n) 81
  (vm-app-imp n))

;; TODO: NATIVE INTEROPERABILITY IS A BITCH
;;   (def args (vm-n-pop n))
;;   (def nfun (vm-pop))
;;   (vm-env-unlnk)
;;   (dlet ((*depth* (+ *depth* 1)))
;;     (app nfun args)))

(def-vm-op VM-ENV-LNK (n) 90
  (vm-env-lnk n))              

(dm vm-ret (chk?)
  (def val  (vm-pop))
  (def typ  (fun-val (%vfn)))
  (vm-env-unlnk)
  (set (%vpc) 0)
  (if (or (not chk?) (isa? val typ))
      val
      (error "RETURN TYPE FAILURE")))

(def-vm-push-op VM-RET () 91
  (vm-ret #f))              

(def-vm-push-op VM-RET-CHK () 92
  (vm-ret #t))

(def-vm-push-op VM-ESC () 100
  ;; (%vm-with-exit (vm-pop))
  (esc ret ((vm-pop) ret))) ;; TODO: ONLY WORKS IF EXIT FRAMES SAVE VM STATE

(def-vm-push-op VM-FIN () 101
  (def cleanup (vm-pop))
  (def main    (vm-pop))
  (dlet ((*depth* (+ *depth* 1)))
    (fin (main) (cleanup))))

(def-vm-push-op VM-TRY () 102
  (def thunk   (vm-pop))
  (def handler (vm-pop))
  (def test    (vm-pop))
  (def info    (vm-pop))
  (def type    (vm-pop))
  (%with-monitor type info test handler thunk))

(def-vm-push-op VM-SIG-FAB (arity nary?) 110
  (def value (vm-pop))
  (def specs (vm-n-pop arity))
  (new <sig> 
    sig-specs specs
    sig-nary? (= nary? 1)
    sig-arity arity
    sig-val   value
    sig-unification-vars '()))

(df %vm-gen-fab (sig name names => <gen>)
  (def i (new <fun-info> fun-info-name name fun-info-names names))
  (def g (new <gen> fun-sig sig fun-info i fun-mets '() fun-cache #f))
  (set (%gen-code g) (%met-code %dispatch))
  g)

(def-vm-push-op VM-GEN-FAB () 111
  (def names (vm-pop))
  (def name  (vm-pop))
  (def sig   (vm-pop))
  (%vm-gen-fab sig name names))

(df %vm-met (args|...)
  (def fn (%fun-reg))
  (set (%vfn) fn)
  (set (%vnm) (%next-methods))
  (when (fun-nary? fn) (vm-push [args (fun-arity fn) *]))
  (rep loop ((i (1- (fun-arity fn))))
    (unless (< i 0) (vm-push [args i]) (loop (1- i))))
  (vm-run (%vm-fun-env-elt fn (%iu 0)))
  (def res (vm-pop))
  (decf (%vsp) (+ (fun-arity fn) (if (fun-nary? fn) 1 0)))
  res)

(df %vm-met-fab (sig nam nams dyn? => <met>)
  (%fab-met (%met-code %vm-met) sig nam nams #f #f))

(df %vm-met-ini (met env => <met>)
  (set (%met-env met) (%vm-fun-env-fab (%iu (len env))))
  (for ((i (from 0)) (e env))
    (set (%vm-fun-env-elt met (%iu i)) e))
  met)

(df %vm-met-fab+ini (sig env nam nams => <met>)
  (def met (%vm-met-fab sig nam nams #f))
  (%vm-met-ini met env))

(def-vm-push-op VM-FUN-FAB-DYN () 112
  (def nams (vm-pop))
  (def nam  (vm-pop))
  (def sig  (vm-pop))
  (%vm-met-fab sig nam nams #t))

(def-vm-push-op VM-FUN-FAB () 113
  (def nams (vm-pop))
  (def nam  (vm-pop))
  (def sig  (vm-pop))
  (%vm-met-fab sig nam nams #f))

(def-vm-op VM-FUN-INI (n l) 114
  (def env (pair (+ l (%vpc)) (vm-n-pop n)))
  (def met (vm-pop))
  (%vm-met-ini met env))

(def-vm-push-op VM-FUN-FAB+INI (n l) 115
  (def env  (pair (+ l (%vpc)) (vm-n-pop n)))
  (def nams (vm-pop))
  (def nam  (vm-pop))
  (def sig  (vm-pop))
  (%vm-met-fab+ini sig env nam nams))

;;;; LINKING/LOADING

(dm vm-get-var (var|<lst>)
  (def e (unchecked-runtime-environment [var 0]))
  (find-binding [var 1] e))

(dm vm-get-vars (vars|<lst> => <tup>)
  (as <tup> (map vm-get-var vars)))

(dm vm-gen-op (op => <int>)
  [*opcodes* op])

(dm vm-patch (code|<lst> labels|<lst> patches|<lst> => <vec>)
  (def ops  (as <vec> code))
  (def labs (fab <tab> 0))
  (for ((label labels))
    (set [labs [label 0]] [label 1]))
  (for ((patch patches))
    (set [ops [patch 1]] 
         (- (- [labs [patch 0]] [patch 1]) 1)))
  ops)

(dm vm-label? (op) (isa? op <sym>))

(dm vm-link (code|<lst> lits|<tup> vars|<tup> => <seq>)
  (def ops  (fab <vec> 0))
  (rep scan ((res '()) (ops code) (labels '()) (patches '()) (pc 0))
    (if (nul? ops)
        (vm-patch (rev! res) labels patches)
        (let ((op (head ops)))
          (if (vm-label? op) 
              (scan res (tail ops) (pair (lst op pc) labels) patches pc)
              (let ((ins (head op)))
                (case ins ;; TODO: SHOULD BE PART OF OP DEFN
                  (('vm-var-get 'vm-var-put 'vm-var-fab 'vm-var-get-or 
                    'vm-mac-fab) 
                   (scan (pair [vars [op 1]]
                               (pair (vm-gen-op ins) res))
                         (tail ops) labels patches (+ pc 2)))
                  (('vm-lit) 
                   (scan (pair [lits [op 1]] (pair (vm-gen-op ins) res))
                         (tail ops) labels patches (+ pc 2)))
                  (#t
                   (rep loop ((res (pair (vm-gen-op ins) res)) 
                              (args (tail op)) (pc (+ pc 1)) (patches patches))
                     (if (nul? args)
                         (scan res (tail ops) labels patches pc)
                         (let ((arg (head args)))
                           (loop (pair arg res) (tail args) (+ pc 1)
                                 (if (vm-label? arg) 
                                     (pair (lst arg pc) patches)
                                     patches)))))))))))))

(dm vm-load (x)
  (def lits (as <tup> [x 0]))
  (def vars (vm-get-vars [x 1]))
  (def code [x 2])
  (def ops  (vm-link code lits vars))
  ops)

(dv vm-init? #f)

(dm vm-init ()
  (set (len *code*) 0)
  (add! *code* (vm-gen-op 'vm-exit))
  (set (%vpc) 1)
  (set (%vsp) 0)
  (set (%vfp) 0)
  )

(dm vm-install (ops)
  (unless vm-init? (vm-init) (set vm-init? #t))
  (def pc (len *code*))
  (for ((op ops))
    (add! *code* op))
  (add! *code* (vm-gen-op 'vm-exit))
  pc)

;;;; RUNNING

(dm vm-run (pc|<int>)
  (def opc  (%vpc))
  (set (%vpc) pc)
  (rep run ()
    (unless (= (%vpc) $vm-ret) ;; value on top of stack
      (trace "%s%d: " (repeat "  " *depth*) (%vpc)) 
      (let ((opcode (vm-nxt-op))
            (op     [*codes* opcode]))
        (op)
        (run))))
  (set (%vpc) opc))

(ddv *vm-running?* #f)

(dm do-vm-top-run (pc|<int> => <any>)
  (set (%vfn) #f)
  (set (%vnm) #f)
  (set (%vsp) 0)
  (set (%vfp) 0)
  (dlet ((*vm-running?* #t))
    (esc exit
      (set *exit* exit)
      (vm-run pc))))

(dm vm-top-run (pc|<int> => <any>)
  (if *vm-running?* (vm-run pc) (do-vm-top-run pc)))

(dm vm-evaluate (exp env)
  (vm-top-run (vm-install (vm-load (asm-exp-in exp env)))))

(dm vm-eval (exp)
  (vm-top-run (vm-install (vm-load (asm-exp exp)))))

;;;; DEBUGGING

(dm vm-disasm (pc|<int> code|<seq>)
  (rep disasm ((res '()) (pc pc))
    (if (< pc (len code))
        (let ((op   [code pc])
              (name [*opnames* op])
              (len  [*oplens* op]))
          (trace "%d: %=\n" pc name)
          (rep garg ((args (lst name)) (pc (+ pc 1)) (i 0))
            (if (= i len)
                (disasm (pair (rev! args) res) pc)
                (garg (pair [code pc] args) (+ pc 1) (+ i 1)))))
        (rev! res))))

(dm recurring-write (port|<out-port> x|<module-binding> d|<int> recur|<fun>)
  (msg port "%s:%s" (binding-module-name x) (binding-name x)))

(dm recurring-write (port|<out-port> x|<sig> d|<int> recur|<fun>)
  (puts port "<Sig ")
  (do (op msg port "%t" _) (sig-specs x))
  (puts port ">"))

(dg asm-exp (x))

(dg asm-ast (x))

(dg out-code (o c))

(dm ppc (c) (out-code out c))

(export
  asm-exp
  asm-exp-in
  out-code
  vm-install
  vm-load
  vm-run
  vm-top-run)
