実験で作ったシミュレータ

readme.md

VMシミュレータ & Regシミュレータ

• 2017年度の実験で作ったシミュレータです。
• 一切の動作保証をしません。
• バグってても怒らないでください。
• デバッグ頑張ってください。
• ライセンス: NYSL

VMシミュレータ

• vm_simulator.mlをプロジェクトに配置してください。
• main.mlにVm_simulator.run vmcodeを適切な場所に書いてください。

  (* Translate to VM (5章後半) *)
  let vmcode = Vm.trans flat in
  dprint (fun () -> "\n(* [VM code] *)\n" ^ (Vm.string_of_vm vmcode));
  Vm_simulator.run vmcode; (* <= この1行で実行されます *)

出力説明

• _toplevelを抜けるまで状態出力を続けます。(無限ループに注意)
• PCはラベル名:何番目の命令か->返り値の代入される場所で表されています。
• PCに付随して返り値の代入される場所を持ってるので、スタックの始め2要素は使ってません。

>>>> _toplevel:0->0, :  move t0, 1 <== 現在のPCと表す命令。
Running :true <== 現在実行中か。
Stack : <== スタックの様子。
-1024, -1025,
-1026, |
-1027, -1028,
-1029, |
Heap : <== ヒープの様子
PCs : <== PCのスタック。_initだけになると終了する。
_toplevel:0->0, _init:0->0,
_toplevel

Regシミュレータ

• reg_simulator.mlをプロジェクトに配置してください。
• main.mlにReg_simulator.run regcodeを適切な場所に書いてください。

let regcode = Opt.optimize !display_cfg Arm_spec.nreg vmcode in
dprint (fun () ->
  "(* [Reg code] *)\n" ^ (Reg.string_of_reg regcode) ^ "\n");
Reg_simulator.run regcode;

出力説明

• vm_simulatorの出力とだいたい同じですが、Regが追加されています。

>>>> _toplevel:1->0, :  ret 1
Running :true
Reg :
0:-42  1:0  2:-42  3:-42  4:-42  5:-42  6:-42  7:-42
Stack :
-42, -43,
-40, |
-44, -45,
-46, |
Heap :
2, 3, |
PCs :

reg_simulator.ml

open Reg

type reg_state = {
  reg : operand list;
  stack : (operand list) list;
  heap  : (operand list) list;
  pc : (label * int * int) list;
  prog : prog;
  running : bool;
}

let string_of_pc pc =
  let (label, i, tgt) = pc in
  label ^ ":" ^ string_of_int i
    ^ "->" ^ string_of_int tgt ^ ", "

let string_of_state state =
  "Running :" ^ string_of_bool state.running ^ "\n" ^
  "Reg : \n" ^
  fst (List.fold_left (fun (res, i) r ->
    (res ^ string_of_int i ^ ":" ^ string_of_operand r ^ "  ", i + 1)
  ) ("", 0) state.reg) ^ "\n" ^
  "Stack :\n" ^
  List.fold_left (fun res st ->
    res ^ fst (List.fold_left (fun (res, i) v ->
      ((res ^ string_of_operand v ^ ", " ^
      if i mod 10 = 1 then "\n" else ""), i + 1)
    ) ("", 0) st) ^ "|\n"
  ) "" state.stack ^
  "Heap :\n" ^
  List.fold_left (fun res st ->
    res ^ List.fold_left (fun res v ->
      res ^ string_of_operand v ^ ", "
    ) "" st ^ "|\n"
  ) "" state.heap ^
  "PCs :\n" ^
  List.fold_left (fun res pc -> res ^ string_of_pc pc
  ) "" state.pc

let rec list_init n v = match n with
    0 -> []
  | k -> v :: (list_init (k - 1) v)

let getl n src = List.nth src n
let setl n src v =
  List.mapi (fun i x -> if i = n then v else x) src

let getv state src = match src with
    Param p -> getl p (List.hd state.stack)
  | Reg r -> getl r state.reg
  | _       -> src

let setv state tgt v =
  {state with
    reg = setl tgt state.reg v
  }

let stack_get state tgt =
  getl (tgt + 2) (List.hd state.stack)

let stack_set state tgt v =
   {state with
      stack = setl (tgt + 2) (List.hd state.stack) v
                :: List.tl state.stack
    }


let push_stack state size =
  {state with
    stack = (list_init (size + 2) (IntV (-42))) :: state.stack
  }

let pop_stack state =
  {state with
    stack = List.tl state.stack
  }

let push_heap state size =
  let res = {state with
    heap = (list_init size (IntV (-42))) :: state.heap
  } in
  (IntV (List.length res.heap - 1), res)

let heap_pos state (IntV p) =
  List.length state.heap - p - 1

let heap_get state p i =
  getl i ( getl (heap_pos state p) state.heap )

let heap_set state p i v =
  let hp = heap_pos state p in
  {state with
    heap = setl hp state.heap (setl i (getl hp state.heap) v)
  }

let push_pc state pc =
  {state with
    pc = pc :: state.pc
  }

let top_pc state = List.hd state.pc

let pop_pc state =
  {state with
    pc = List.tl state.pc
  }

let set_pc state pc =
  push_pc (pop_pc state) pc

let empty_pc state =
  List.length state.pc = 1

let next state =
  let (label, pc, tgt) = top_pc state in
  set_pc state (label, pc + 1, tgt)

let endvm state =
  {state with
    running = false
  }

let get_decl state label = 
  List.find (fun (ProcDecl (l, x, instr)) -> label = l) state.prog
 
let get_instr state =
  let (label, pc, tgt) = top_pc state in
  let ProcDecl (_,_,instr) = get_decl state label in
  List.nth instr pc

let local_vars state label =
  let ProcDecl (_,x,_) = get_decl state label in x

let jump state label =
  let (fn, pc, tgt) = top_pc state in
  let ProcDecl (fn, x, instr) = get_decl state fn in
  let (_, num) = List.find (fun (ins, i) ->
    match ins with Label k -> k = label | _ -> false) 
    (List.mapi (fun i x -> (x, i)) instr) in
    set_pc state (fn, num, tgt)

let run_instr state instr = match instr with
    Move (tgt, src) ->
      next (setv state tgt (getv state src))
  | BinOp (tgt, op, src1, src2) ->
      let (IntV v1) = getv state src1 in
      let (IntV v2) = getv state src2 in
      let res = (match op with
        Syntax.Plus -> v1 + v2
      | Syntax.Mult -> v1 * v2
      | Syntax.Lt   -> if v1 < v2 then 1 else 0) in
      next (setv state tgt (IntV res))
  | Label l -> next state
  | BranchIf (cmp, l) -> 
    let IntV v = getv state cmp in
    if 0 < v then jump state l else next state
  | Goto l -> jump state l
  | Call (R tgt, src1, [src2; src3]) ->
     let Proc l = getv state src1 in
     let v2 = getv state src2 in
     let v3 = getv state src3 in
     let size = local_vars state l in
     let state = next state in
     let state = push_stack state size in
     let state = stack_set state (-2) v2 in
     let state = stack_set state (-1) v3 in
     push_pc state (l, 0, tgt)
  | Return src1 ->
     let res = getv state src1 in
     let (label, l, tgt) = top_pc state in
     let state = pop_pc state in
     let state = pop_stack state in
     let state = setv state tgt res in
     if empty_pc state then endvm state else state
  | Malloc (R tgt, srcs) ->
     let (res, state) = push_heap state (List.length srcs) in
     let state = setv state tgt res in
     let (state, _) = List.fold_left (fun (state, i) src ->
         let v = getv state src in
         (heap_set state res i v, i + 1)
     ) (state, 0) srcs in
     next state
  | Read (R tgt, src, id) ->
     let v = getv state src in
     next (setv state tgt (heap_get state v id))
  | Load (tgt, off) ->
     next (setv state tgt (stack_get state off))
  | Store (tgt, off) ->
     next (stack_set state off (getv state (Reg tgt)))

let init_vm prog =
  let state = {
    stack = [];
    reg = list_init 8 (IntV (-42));
    heap = [];
    pc = [("_toplevel", 0, 0); ("_init", 0, 0)];
    prog = prog;
    running = true;
  } in
  { state with
    stack = [
      ([IntV (-42); IntV (-43)] @
        list_init (local_vars state "_toplevel") (IntV (-40)));
      [IntV (-44); IntV (-45); IntV (-46)]];
  }

let rec run_vm state =
  if state.running then
    let instr = get_instr state in
    print_endline ("\n>>>> " ^
      string_of_pc (List.hd state.pc) ^ ": " ^
      Reg.string_of_instr " " " " instr);
      print_endline (string_of_state state);
    let state = run_instr state instr in
    run_vm state
  else
    state

let run prog =
  run_vm (init_vm prog)

vm_simulator.ml

open Vm

type vm_state = {
  stack : (operand list) list;
  heap  : (operand list) list;
  pc : (label * int * int) list;
  prog : prog;
  running : bool;
}

let string_of_pc pc =
  let (label, i, tgt) = pc in
  label ^ ":" ^ string_of_int i
    ^ "->" ^ string_of_int tgt ^ ", "

let string_of_state state =
  "Running :" ^ string_of_bool state.running ^ "\n" ^
  "Stack :\n" ^
  List.fold_left (fun res st ->
    res ^ fst (List.fold_left (fun (res, i) v ->
      ((res ^ string_of_operand v ^ ", " ^
      if i mod 10 = 1 then "\n" else ""), i + 1)
    ) ("", 0) st) ^ "|\n"
  ) "" state.stack ^
  "Heap :\n" ^
  List.fold_left (fun res st ->
    res ^ List.fold_left (fun res v ->
      res ^ string_of_operand v ^ ", "
    ) "" st ^ "|\n"
  ) "" state.heap ^
  "PCs :\n" ^
  List.fold_left (fun res pc -> res ^ string_of_pc pc
  ) "" state.pc

let rec list_init n v = match n with
    0 -> []
  | k -> v :: (list_init (k - 1) v)

let getl n src = List.nth src n
let setl n src v =
  List.mapi (fun i x -> if i = n then v else x) src

let getv state src = match src with
    Param p -> getl p (List.hd state.stack)
  | Local l -> getl (l + 2) (List.hd state.stack)
  | _       -> src

let setv state tgt v =
  {state with
    stack = setl (tgt + 2) (List.hd state.stack) v
              :: List.tl state.stack
  }

let push_stack state size =
  {state with
    stack = (list_init (size + 2) (IntV (-42))) :: state.stack
  }

let pop_stack state =
  {state with
    stack = List.tl state.stack
  }

let push_heap state size =
  let res = {state with
    heap = (list_init size (IntV (-42))) :: state.heap
  } in
  (IntV (List.length res.heap - 1), res)

let heap_pos state (IntV p) =
  List.length state.heap - p - 1

let heap_get state p i =
  getl i ( getl (heap_pos state p) state.heap )

let heap_set state p i v =
  let hp = heap_pos state p in
  {state with
    heap = setl hp state.heap (setl i (getl hp state.heap) v)
  }

let push_pc state pc =
  {state with
    pc = pc :: state.pc
  }

let top_pc state = List.hd state.pc

let pop_pc state =
  {state with
    pc = List.tl state.pc
  }

let set_pc state pc =
  push_pc (pop_pc state) pc

let empty_pc state =
  List.length state.pc = 1

let next state =
  let (label, pc, tgt) = top_pc state in
  set_pc state (label, pc + 1, tgt)

let endvm state =
  {state with
    running = false
  }

let get_decl state label = 
  print_string label;
  List.find (fun (ProcDecl (l, x, instr)) -> label = l) state.prog
 
let get_instr state =
  let (label, pc, tgt) = top_pc state in
  let ProcDecl (_,_,instr) = get_decl state label in
  List.nth instr pc

let local_vars state label =
  let ProcDecl (_,x,_) = get_decl state label in x

let jump state label =
  let (fn, pc, tgt) = top_pc state in
  let ProcDecl (fn, x, instr) = get_decl state fn in
  let (_, num) = List.find (fun (ins, i) ->
    match ins with Label k -> k = label | _ -> false) 
    (List.mapi (fun i x -> (x, i)) instr) in
    set_pc state (fn, num, tgt)

let run_instr state instr = match instr with
    Move (tgt, src) ->
      next (setv state tgt (getv state src))
  | BinOp (tgt, op, src1, src2) ->
      let (IntV v1) = getv state src1 in
      let (IntV v2) = getv state src2 in
      let res = (match op with
        Syntax.Plus -> v1 + v2
      | Syntax.Mult -> v1 * v2
      | Syntax.Lt   -> if v1 < v2 then 1 else 0) in
      next (setv state tgt (IntV res))
  | Label l -> next state
  | BranchIf (cmp, l) -> 
    let IntV v = getv state cmp in
    if 0 < v then jump state l else next state
  | Goto l -> jump state l
  | Call (tgt, src1, [src2; src3]) ->
     let Proc l = getv state src1 in
     let v2 = getv state src2 in
     let v3 = getv state src3 in
     let size = local_vars state l in
     let state = next state in
     let state = push_stack state size in
     let state = setv state (-2) v2 in
     let state = setv state (-1) v3 in
     push_pc state (l, 0, tgt)
  | Return src1 ->
     let res = getv state src1 in
     let (label, l, tgt) = top_pc state in
     let state = pop_pc state in
     let state = pop_stack state in
     let state = setv state tgt res in
     if empty_pc state then endvm state else state
  | Malloc (tgt, srcs) ->
     let (res, state) = push_heap state (List.length srcs) in
     let (state, _) = List.fold_left (fun (state, i) src -> 
       (heap_set state res i (getv state src), i + 1)
     ) (state, 0) srcs in
     next (setv state tgt res)
  | Read (tgt, src, id) ->
     let v = getv state src in
     next (setv state tgt (heap_get state v id))

let init_vm prog =
  let state = {
    stack = [];
    heap = [];
    pc = [("_toplevel", 0, 0); ("_init", 0, 0)];
    prog = prog;
    running = true;
  } in
  { state with
    stack = [
      ([IntV (-1024); IntV (-1025)] @
        list_init (local_vars state "_toplevel") (IntV (-1026)));
      [IntV (-1027); IntV (-1028); IntV (-1029)]];
  }

let rec run_vm state =
  if state.running then
    let instr = get_instr state in
    print_endline ("\n>>>> " ^
      string_of_pc (List.hd state.pc) ^ ": " ^
      Vm.string_of_instr " " " " instr);
      print_endline (string_of_state state);
    let state = run_instr state instr in
    run_vm state
  else
    state

let run prog =
  run_vm (init_vm prog)