source: Deliverables/D2.2/8051/src/LIN/LINInterpret.ml @ 640

(** This module provides an interpreter for the LIN language. *)


let error_prefix = "LIN interpret"
let error s = Error.global_error error_prefix s


module Mem = Driver.LINMemory
module Val = Mem.Value
let chunk = Driver.LINMemory.int_size
module Eval = I8051.Eval (Val)

(* External RAM size *)
let ext_ram_size = 1000
(* Internal RAM size *)
let int_ram_size = 100


let change_offset v off =
  if Val.is_pointer v then
    let (b, _) = Val.to_pointer v in
    Val.of_pointer (b, off)
  else error ((Val.to_string v) ^ " is not a pointer.")


(* Memory *)

type memory = LIN.function_def Mem.memory

(* Hardware registers environments. They associate a value to the each hardware
   register. *)

type hdw_reg_env = Val.t I8051.RegisterMap.t

(* Execution states. *)

type state =
    { pc     : Val.t ;
      isp    : Val.t ;
      carry  : Val.t ;
      renv   : hdw_reg_env ;
      mem    : memory ;
      trace  : CostLabel.t list }


(* Helpers *)

let change_pc st pc = { st with pc = pc }
let change_isp st isp = { st with isp = isp }
let change_carry st carry = { st with carry = carry }
let change_renv st renv = { st with renv = renv }
let change_mem st mem = { st with mem = mem }
let change_trace st trace = { st with trace = trace }

let empty_state =
  { pc     = Val.undef ;
    isp    = Val.undef ;
    carry  = Val.undef ;
    renv   = I8051.RegisterMap.empty ;
    mem    = Mem.empty ;
    trace  = [] }


let int_fun_of_ptr mem ptr = match Mem.find_fun_def mem ptr with
  | LIN.F_int def -> def
  | _ -> error "Trying to fetch the definition of an external function."

let current_int_fun st = int_fun_of_ptr st.mem st.pc

let fetch_stmt st =
  let msg =
    Printf.sprintf "%s does not point to a statement." (Val.to_string st.pc) in
  let error () = error msg in
  if Val.is_pointer st.pc then
    let (_, off) = Val.to_pointer st.pc in
    let def = int_fun_of_ptr st.mem st.pc in
    List.nth def (Val.Offset.to_int off)
  else error ()

let init_fun_call st ptr =
  change_pc st (change_offset ptr Val.Offset.zero)

let next_pc st =
  change_pc st (Val.succ st.pc)

let add_reg r v st =
  let renv = I8051.RegisterMap.add r v st.renv in
  change_renv st renv

let get_reg r st =
  if I8051.RegisterMap.mem r st.renv then I8051.RegisterMap.find r st.renv
  else error ("Unknown hardware register " ^ (I8051.print_register r) ^ ".")

let push st v =
  let mem = Mem.store2 st.mem chunk st.isp v in
  let isp = Val.succ st.isp in
  change_mem (change_isp st isp) mem

let pop st =
  let isp = Val.pred st.isp in
  let st = change_isp st isp in
  let v = Mem.load2 st.mem chunk st.isp in
  (st, v)

let save_ra st =
  let ra = Val.succ st.pc in
  let vs = Val.break ra 2 in
  let st = push st (List.nth vs 1) in
  let st = push st (List.nth vs 0) in
  st

let find_label lbl =
  let rec aux i = function
  | [] -> error (Printf.sprintf "Unknown label %s." lbl)
  | LIN.St_label lbl' :: _ when lbl' = lbl -> i
  | _ :: code -> aux (i+1) code
  in
  aux 0

let pointer_of_label st lbl =
  let code = current_int_fun st in
  let off = find_label lbl code in
  change_offset st.pc (Val.Offset.of_int off)

let goto st lbl =
  change_pc st (pointer_of_label st lbl)

let return_pc st =
  let (st, pch) = pop st in
  let (st, pcl) = pop st in
  Val.merge [pch ; pcl]


(*
let get_int () =
  try Val.of_int (int_of_string (read_line ()))
  with Failure "int_of_string" -> error "Failed to scan an integer."
let get_float () =
  try Val.of_float (float_of_string (read_line ()))
  with Failure "float_of_string" -> error "Failed to scan a float."

let interpret_external
    (mem  : memory)
    (def  : AST.external_function)
    (args : Val.t list) :
    memory * Val.t list =
  match def.AST.ef_tag, args with
    | s, _ when s = Primitive.scan_int ->
      (mem, [get_int ()])
    | "scan_float", _ ->
      (mem, [get_float ()])
    | s, v :: _ when s = Primitive.print_int && Val.is_int v ->
      Printf.printf "%d" (Val.to_int v) ;
      (mem, [Val.zero])
    | "print_float", v :: _ when Val.is_float v ->
      Printf.printf "%f" (Val.to_float v) ;
      (mem, [Val.zero])
    | "print_ptr", v :: _ when Val.is_pointer v ->
      let (b, off) = Val.to_pointer v in
      Printf.printf "block: %s, offset: %s"
        (Val.Block.to_string b) (Val.Offset.to_string off) ;
      (mem, [Val.zero])
    | s, v :: _ when s = Primitive.print_intln && Val.is_int v ->
      Printf.printf "%d\n" (Val.to_int v) ;
      (mem, [Val.zero])
    | "print_floatln", v :: _ when Val.is_float v ->
      Printf.printf "%f" (Val.to_float v) ;
      (mem, [Val.zero])
    | "print_ptrln", v :: _ when Val.is_pointer v ->
      let (b, off) = Val.to_pointer v in
      Printf.printf "block: %s, offset: %s\n"
        (Val.Block.to_string b) (Val.Offset.to_string off) ;
      (mem, [Val.zero])
    | s, v :: _ when s = Primitive.alloc ->
      let (mem, ptr) = Mem.alloc mem v in
      let vs = Val.break ptr 2 in
      (mem, vs)
    | s, v1 :: v2 :: _ when s = Primitive.modulo ->
      (mem, [Val.modulo v1 v2])

    (* The other cases are either a type error (only integers and pointers
       may not be differenciated during type checking) or an unknown
       function. *)
    | "print_int", _ | "print_intln", _ ->
      error "Illegal cast from pointer to integer."
    | "print_ptr", _ | "print_ptrln", _ ->
      error "Illegal cast from integer to pointer."
    | ef_tag, _ -> error ("Unknown external function \"" ^ ef_tag ^ "\".")
*)


let interpret_call st f =
  let ptr = Mem.find_global st.mem f in
  match Mem.find_fun_def st.mem ptr with
    | LIN.F_int def ->
      let st = save_ra st in
      init_fun_call st ptr
    | LIN.F_ext def -> assert false (* TODO *)

let interpret_return st =
  let pc = return_pc st in
  change_pc st pc

let interpret_stmt st stmt =
  match stmt with

    | LIN.St_goto lbl ->
      goto st lbl

    | LIN.St_label _ ->
      next_pc st

    | LIN.St_comment s ->
(*
      Printf.printf "*** %s ***\n\n%!" s ;
*)
      next_pc st

    | LIN.St_cost cost_lbl ->
      let st = change_trace st (cost_lbl :: st.trace) in
      next_pc st

    | LIN.St_int (r, i) ->
      let st = add_reg r (Val.of_int i) st in
      next_pc st

    | LIN.St_pop ->
      let (st, v) = pop st in
      let st = add_reg I8051.a v st in
      next_pc st

    | LIN.St_push ->
      let v = get_reg I8051.a st in
      let st = push st v in
      next_pc st

    | LIN.St_addr x ->
      let v = Mem.find_global st.mem x in
      let vs = Val.break v 2 in
      let st = add_reg I8051.dph (List.nth vs 0) st in
      let st = add_reg I8051.dpl (List.nth vs 1) st in
      next_pc st

    | LIN.St_from_acc destr ->
      let st = add_reg destr (get_reg I8051.a st) st in
      next_pc st

    | LIN.St_to_acc srcr ->
      let st = add_reg I8051.a (get_reg srcr st) st in
      next_pc st

    | LIN.St_opaccs opaccs ->
      let v =
        Eval.opaccs opaccs
          (get_reg I8051.a st)
          (get_reg I8051.b st) in
      let st = add_reg I8051.a v st in
      next_pc st

    | LIN.St_op1 op1 ->
      let v = Eval.op1 op1 (get_reg I8051.a st) in
      let st = add_reg I8051.a v st in
      next_pc st

    | LIN.St_op2 (op2, srcr) ->
      let (v, carry) =
        Eval.op2 st.carry op2
          (get_reg I8051.a st)
          (get_reg srcr st) in
      let st = change_carry st carry in
      let st = add_reg I8051.a v st in
      next_pc st

    | LIN.St_clear_carry ->
      let st = change_carry st Val.zero in
      next_pc st

    | LIN.St_load ->
      let addr =
        Val.merge (List.map (fun r -> get_reg r st) [I8051.dph ; I8051.dpl]) in
      let v = Mem.load2 st.mem chunk addr in
      let st = add_reg I8051.a v st in
      next_pc st

    | LIN.St_store ->
      let addr =
        Val.merge (List.map (fun r -> get_reg r st) [I8051.dph ; I8051.dpl]) in
      let mem = Mem.store2 st.mem chunk addr (get_reg I8051.a st) in
      let st = change_mem st mem in
      next_pc st

    | LIN.St_call_id f ->
      interpret_call st f

    | LIN.St_condacc lbl_true ->
      let v = get_reg I8051.a st in
      if Val.is_true v then goto st lbl_true
      else
        if Val.is_false v then next_pc st
        else error "Undecidable branchment."

    | LIN.St_return ->
      interpret_return st


let print_renv renv =
  let f r v =
    if not (Val.eq v Val.undef) then
    Printf.printf "\n%s = %s%!" (I8051.print_register r) (Val.to_string v) in
  I8051.RegisterMap.iter f renv

let print_state st =
  Printf.printf "PC: %s\n%!" (Val.to_string st.pc) ;
  Printf.printf "SP: %s\n%!"
    (Val.to_string (Val.merge [get_reg I8051.sph st ; get_reg I8051.spl st])) ;
  Printf.printf "ISP: %s%!" (Val.to_string st.isp) ;
  print_renv st.renv ;
  Printf.printf "\nC = %s%!" (Val.to_string st.carry) ;
  Mem.print st.mem ;
  Printf.printf "\n%!"

let compute_result st =
  let v = get_reg I8051.dpl st in
  if Val.is_int v then IntValue.Int8.cast (Val.to_int_repr v)
  else IntValue.Int8.zero

let rec iter_small_step print_result st =
(*
  (* <DEBUG> *)
  print_state st ;
  (* </DEBUG> *)
*)
  match fetch_stmt st with
    | LIN.St_return when Val.eq (return_pc st) Val.zero ->
      let (res, cost_labels) as trace =
        (compute_result st, List.rev st.trace) in
      if print_result then
        Printf.printf "LIN: %s\n%!" (IntValue.Int8.to_string res) ;
      trace
    | stmt ->
      let st' = interpret_stmt st stmt in
      iter_small_step print_result st'


let add_global_vars =
  List.fold_left
    (fun mem (id, size) -> Mem.add_var mem id [AST.Data_reserve size])

let add_fun_defs =
  List.fold_left (fun mem (f_id, f_def) -> Mem.add_fun_def mem f_id f_def)

let init_prog (st : state) (p : LIN.program) : state =
  let mem = add_global_vars (add_fun_defs st.mem p.LIN.functs) p.LIN.vars in
  change_mem st mem

let init_renv st sp =
  let f r st = add_reg r Val.undef st in
  let st = I8051.RegisterSet.fold f I8051.registers st in
  let vs = Val.break sp 2 in
  let sph = List.nth vs 0 in
  let spl = List.nth vs 1 in
  let st = add_reg I8051.sph sph st in
  let st = add_reg I8051.spl spl st in
  st

let init_sp st =
  let (mem, sp) = Mem.alloc st.mem ext_ram_size in
  let (b, _) = Val.to_pointer sp in
  let sp = Val.of_pointer (b, Val.Offset.of_int ext_ram_size) in
  let st = change_mem st mem in
  (st, sp)

let init_isp st =
  let (mem, isp) = Mem.alloc st.mem int_ram_size in
  let st = change_mem (change_isp st isp) mem in
  let vs = Val.break Val.zero 2 in
  let st = push st (List.nth vs 1) in
  let st = push st (List.nth vs 0) in
  st  

let init_main_call st main =
  let ptr = Mem.find_global st.mem main in
  match Mem.find_fun_def st.mem ptr with
    | LIN.F_int def ->
      init_fun_call st ptr
    | _ -> error ("Cannot execute the main (\"" ^ main ^ "\"): it is external.")


(* Before interpreting, the environment is initialized:
   - Add function definitions to the memory and reserve space for the globals.
   - Allocate memory to emulate the external stack and initialize the external
     stack pointer.
   - Allocate memory to emulate the internal stack and initialize the internal
     stack pointer.
   - Initialiaze the physical register environment. All are set to 0, except for
     the stack pointer registers that take the high and low bits of the external
     stack pointer.
   - Initialize a call to the main (set the current program counter to the
     beginning of the function).
   - Initialize the carry flag to 0. *)

let interpret print_result p = match p.LIN.main with
  | None -> (IntValue.Int8.zero, [])
  | Some main ->
    let st = empty_state in
    let st = init_prog st p in
    let (st, sp) = init_sp st in
    let st = init_isp st in
    let st = init_renv st sp in
    let st = init_main_call st main in
    let st = change_carry st Val.zero in
    iter_small_step print_result st