(* IMPLEMENTIERUNG der VIRTUELLEN MASCHINE M *)
(* *)
(* Buch: Programmierung - Eine Einführung in die Informatik *)
(* Stand: 30. April 2007 *)
(* Mehr Infos: www.ps.uni-saarland.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 *)