(* source language ---------------------------------------------------------- *)

type var = string
module SRC = struct

  (* An object language: a simple datatype of 64-bit integer expressions *)
  type exp =
    | Var of var          (* string representing an object-language variable *)
    | Const of int64      (* a constant int64 value *)
    | Add of exp * exp    (* sum of two expressions *)
    | Mul of exp * exp    (* product of two expressions *)
    | Neg of exp          (* negation of an expression *)


  (* The global context of available variables and their (immutable) values. *)
  let globals : (var * int64) list =
    [
      "X1", 1L
    ; "X2", 2L
    ; "X3", 3L
    ; "X4", 4L
    ; "X5", 5L
    ; "X6", 6L
    ; "X7", 7L
    ; "X8", 8L
    ]

  (* 
        (1 + X4) + (3 + (X1 * 5) )
  *)
  let example : exp =
    Add(Add(Const 1L, Var "X4"),
        Add(Const 3L, Mul(Var "X1",
                         Const 5L)))
  
  (* Note: a "well-formed" SRC expression uses only variables found in the global
     context. (We omit the "scope checker" here.)*)                         
end





(* simple let language intermediate representation -------------------------- *)
module IR = struct
  (* Unique identifiers for temporaries. *)
  type uid = int

  (* "gensym" -- generate a new unique identifier *)
  let mk_uid : unit -> uid =
    let ctr = ref 0 in
    fun () -> 
      ctr := !ctr + 1;
      !ctr

  (* syntactic values / operands *)
  type opn = 
    | Id of uid
    | Const of int64
    | Var of var

  (* binary operations *)
  type bop =
    | Add
    | Mul
             
  (* instructions *)
  (* note that there is no nesting of operations! *)
  type insn =
    | Let of uid * bop * opn * opn

  type program = {
    globals: (var * int64) list;
    insns: insn list;
    ret: opn
  }


  (* Pretty printing *)
  let pp_uid u = Printf.sprintf "tmp%d" u
  let pp_var x = Printf.sprintf "var%s" x
  let pp_int64 c = (Int64.to_string c)^"L"

  let pp_opn = function 
    | Id u    -> pp_uid u
    | Const c -> pp_int64 c
    | Var x   -> pp_var x

  let pp_bop = function
    | Add -> "add"
    | Mul -> "mul"

  let pp_insn = function
    | Let (u, bop, op1, op2) ->
      Printf.sprintf "let %s = %s %s %s"
        (pp_uid u) (pp_bop bop) (pp_opn op1) (pp_opn op2)

  let pp_global = function (x,c) ->
    Printf.sprintf "let %s = %s" (pp_var x) (pp_int64 c)

  let pp_program {globals; insns; ret} =
    Printf.sprintf "%s\n;;\n%s in\n  ret %s"
    (String.concat "\n" (List.map pp_global globals)) 
    (String.concat " in\n" (List.map pp_insn insns)) 
    (pp_opn ret)


  module MLMeaning = struct
    let add = Int64.add
    let mul = Int64.mul
    let ret x = x
  end
  
end





module Compile = struct
  open SRC

  (* Expressions produce answers, so the result of compiling an expression
     is a list of instructions and an operand that will contain the final
     result of comping the expression. 

     - we can share the code common to binary operations.
  *)
  
  let rec compile_exp (e:exp) : (IR.insn list) * IR.opn =
    let compile_bop bop e1 e2 = 
        let ins1, ret1 = compile_exp e1 in
        let ins2, ret2 = compile_exp e2 in
        let ret = IR.mk_uid () in
        ins1 @ ins2 @ IR.[Let (ret, bop, ret1, ret2)], IR.Id ret
    in
    begin match e with
      | Var x       -> [], IR.Var x
      | Const c     -> [], IR.Const c
      | Add(e1, e2) -> compile_bop IR.Add e1 e2
      | Mul(e1, e2) -> compile_bop IR.Mul e1 e2
      | Neg(e1)     -> compile_bop IR.Mul e1 (Const(-1L))
    end
  
  let compile (e:exp) : IR.program =
    let globals = SRC.globals in
    let insns, ret = compile_exp e in
    IR.{ globals; insns; ret }

end