(*        IMPLEMENTIERUNG der VIRTUELLEN MASCHINE M            *)
(*                                                             *)
(* Buch: Programmierung - Eine Einführung in die Informatik    *)
(* Stand: 30. April 2007                                       *)
(* Mehr Infos: www.ps.uni-sb.de/prog-buch/                     *)


type index = int
type noi   = int                (* number of instructions      *)
type noa   = int                (* number of arguments         *)
type ca    = int                (* code address                *)
type ra    = int                (* return address (code)       *)
type sa    = int                (* stack address               *)
type ha    = int                (* heap address                *)

datatype instruction =
   halt                        (* halt machine                *)
 | con     of int              (* push constant               *)
 | add                         (* addition                    *)
 | sub                         (* substraction                *)
 | mul                         (* multiplication              *)
 | leq                         (* less or equal test          *)
 | branch  of noi              (* unconditional branch        *)
 | cbranch of noi              (* conditional branch          *)
 | getS    of index            (* push value from stack cell  *)
 | putS    of index            (* update stack cell           *)
 | new     of noa              (* allocate block of size noa  *)
 | getH    of index            (* push value from heap cell   *)
 | putH    of index            (* update heap cell            *)
 | proc    of noa * noi        (* begin of procedure code     *)
 | arg     of index            (* push argument               *)
 | call    of ca               (* call procedure              *)
 | return                      (* return from procedure call  *)
 | callR   of ca               (* call procedure and return   *)

type code = instruction list

fun iterup m n s f = if m>n then s else iterup (m+1) n (f(m,s)) f
fun iterdn n m s f = if n<m then s else iterdn (n-1) m (f(n,s)) f

functor Store
   (type data
    val init  : data
    val size  : int
    val error : string -> exn)
:> sig
    type address = int
    val push    : data -> unit
    val la      : unit -> address  (* last allocated address *)
    val get     : address -> data
    val put     : address -> data -> unit
    val pop     : unit -> data
    val release : address -> unit
    val clear   : unit -> unit
    val show    : unit -> (address * data) list
end
=
struct
   type address = int
   val array = Array.array(size,init)
   val lar = ref ~1
   fun la () = !lar
   fun push x = if !lar<size-1
        then (lar:= !lar+1; Array.update(array, !lar, x))
                else raise error "out of memory"
   fun check a = if 0<=a andalso a <= !lar then a
         else raise error "illegal address"
   fun get a = Array.sub(array, check a)
   fun put a x = Array.update(array, check a, x)
   fun pop () = #1(get(!lar), lar:= !lar-1)
   fun release a = lar:= check a - 1
   fun clear () = lar:= ~1
   fun show () = iterdn (!lar) 0 nil (fn (a,es) => (a,get a)::es)
end

exception Error of string
fun error module message = Error (module^": "^message)

(* die virtuelle Maschine *)

structure VM :> sig
   val exec        : code -> int list
   val load        : code -> unit
   val run         : unit -> int list
   val step        : unit -> int list
   val pc          : ca ref
   val showProgram : unit -> (ca * instruction) list
   val showHeap    : unit -> (ha * int) list
   val showStack   : unit -> (sa * int) list
   val showFP      : unit -> sa
 end
= struct
 structure P :> sig  (* Program Store *)
       val push  : instruction -> unit
       val get   : ca -> instruction
       val clear : unit -> unit
       val show  : unit -> (ca * instruction) list
  end
 = Store(
     type data = instruction
     val init  = halt
     val size  = 1000
     val error = error "Program store"
 )

 structure H :> sig  (* Heap *)
     val push  : int -> unit
     val la    : unit -> ha
     val get   : ha -> int
     val put   : ha -> int -> unit
     val clear : unit -> unit
     val show  : unit -> (ha * int) list
  end
 = Store(
     type data = int
     val init  = ~1
     val size  = 1000
     val error = error "Heap"
 )

 structure S :> sig  (* Stack *)
     val push    : int -> unit
     val get     : sa -> int
     val put     : sa -> int -> unit
     val pop     : unit -> int
     val clear   : unit -> unit
     val call'   : noa -> ra -> unit
     val return' : unit -> ra
     val callR'  : noa -> unit
     val arg'    : index -> unit
     val show    : unit -> (sa * int) list
     val showFP  : unit -> sa
  end
 = struct
   structure St = Store(type data = int
              val init  = 0
              val size  = 1000
              val error = error "Stack"
   )
   open St
   val fp = ref ~1
   fun showFP () = !fp
   fun clear () = (St.clear() ; fp:= ~1)
   fun call' noa ra = (push noa; push(!fp); fp:=la(); push ra)
   fun getReturnAdress () = get(!fp+1)
   fun getNOA () = get(!fp-1)    (* get number of arguments *)
   fun arg' i = push(get(!fp-1-i))
   fun popFrame noa = let
     val tpf = !fp-getNOA()-2  (* top of previous frame *)
     val afr = la()-noa+1      (* sa of first result *)
     val dist = afr-tpf-1      (* distance for move *)
   in
     fp:= get(!fp);
     iterup (tpf+1) (tpf+noa) () (fn (a,()) => put a (get (a+dist)));
     release(tpf+noa+1)
   end
   fun return' () = #1(getReturnAdress(), popFrame 1)
     fun callR' noa = let
     val ra = getReturnAdress()
   in
     popFrame noa;
     call' noa ra
   end
 end

 fun getNoa ca = case P.get ca of proc(noa,_) => noa
                | _  => raise error "VM" "proc expected"

 fun new' noa = if noa<1 then raise error "VM" "new: argument not postive"
       else let val a = H.la()+1
       in  iterup 1 noa () (fn _ => H.push(S.pop()));
           S.push a
      end

 val pc = ref ~1
 fun ipc i = pc:= !pc+i  (* increment pc *)
 exception Halt

 fun execute instruction = case instruction of
     halt => raise Halt
   | con n => (S.push n ; ipc 1)
   | add => (S.push (S.pop()+S.pop()) ; ipc 1)
   | sub => (S.push (S.pop()-S.pop()) ; ipc 1)
   | mul => (S.push (S.pop()*S.pop()) ; ipc 1)
   | leq => (S.push (if S.pop()<=S.pop() then 1 else 0) ; ipc 1)
   | branch noi => ipc noi
   | cbranch noi => if S.pop()=0 then ipc noi else ipc 1
   | getS sa => (S.push (S.get sa) ; ipc 1)
   | putS sa => (S.put sa (S.pop()) ; ipc 1)
   | new noa => (new' noa ; ipc 1)
   | getH i => (S.push (H.get (S.pop()+i)) ; ipc 1)
   | putH i => (H.put (S.pop()+i) (S.pop()) ; ipc 1)
   | proc(noa, noi) => ipc noi
   | arg i => (S.arg' i ; ipc 1)
   | return => pc:=S.return'()+1
   | call ca => (S.call' (getNoa ca) (!pc) ; pc:=ca+1)
   | callR ca => (S.callR' (getNoa ca) ; pc:=ca+1)

 fun load code = (P.clear(); S.clear(); H.clear(); List.app P.push code; pc:=0)

 fun showStack () = map #2 (S.show())
 fun step ()   = (execute(P.get(!pc)) ; showStack())
 fun run () = ((while true do execute(P.get(!pc))) handle Halt => () ;
        showStack())
 fun exec code = (load code; run())
 val showHeap  = H.show
 val showProgram  = P.show
 val showStack  = S.show
 val showFP = S.showFP
end (* VM *)