Source

ocaml-llvm-phantom / lib / module.ml

open Spotlib.Spot
module P = Spotlib.Spot.Phantom
open P.Open

module E = Llvm_executionengine
module T = Llvm_target
module S = Llvm_scalar_opts

module Make(A : sig 
  val context : Context.t
  val name : string
  val opt : bool
end) = struct
  module Type = Type_ctxt.Make(A)
  module Value = Value_ctxt.Make(A)
  open Type
  open Value

  include A

  (* Initializtion *)

  let module_ = Llvm.create_module context name

  (* Create the JIT. *)
  let engine = E.ExecutionEngine.create module_

  let fpm = Llvm.PassManager.create_function module_
    
  let _ =
    if opt then begin
      (* Set up the optimizer pipeline.  Start with registering info about how the
       * target lays out data structures. *)
      T.TargetData.add (E.ExecutionEngine.target_data engine) fpm;
      (* Do simple "peephole" optimizations and bit-twiddling optzn. *)
      S.add_instruction_combination fpm;
      (* reassociate expressions. *)
      S.add_reassociation fpm;
      (* Eliminate Common SubExpressions. *)
      S.add_gvn fpm;
      (* Simplify the control flow graph (deleting unreachable blocks, etc). *)
      S.add_cfg_simplification fpm;
      ignore (Llvm.PassManager.initialize fpm)
    end

  (* module functions *)
      
  let dispose () = Llvm.dispose_module module_
  let target_triple () = Llvm.target_triple module_
  let set_target_triple s = Llvm.set_target_triple s module_
  let data_layout () = Llvm.data_layout module_
  let set_data_layout s = Llvm.set_data_layout s module_
  (* let delete_type_name = delete_type_name *)
  let set_inline_asm = Llvm.set_module_inline_asm module_

  let define_type_name n (t : 'a typ) = 
    let name = A.name ^ "." ^ n in
    if Llvm.define_type_name name !<t module_ then
      match Llvm.type_by_name module_ name with
      | Some t -> 
          let t = (P.unsafe t : 'a typ) in
          Type.define_name ~modname:A.name n t;
          t
      | None -> assert false
    else failwithf "define_type_name %s failed" n

  (* let delete_type_name : I do not think I need such a function. *)

  let type_by_name : string -> unknown typ option = fun name ->
    Option.map ~f:(!>) (Llvm.type_by_name module_ name)

  let dump () = Llvm.dump_module module_
  
  module ExecutionEngine = struct
    let run_function (lv : ('args -> 'b) pointer v) (args : 'args Genvalue.vs) : 'b Genvalue.v = 
      P.unsafe & 
        E.ExecutionEngine.run_function !<lv (P.List.to_array args) engine
    let run_function0 lv () = run_function lv P.c0
    let run_function1 lv a0 = run_function lv (P.c1 a0)
    let run_function2 lv a0 a1 = run_function lv (P.c2 a0 a1)
    let run_function3 lv a0 a1 a2 = run_function lv (P.c3 a0 a1 a2)
    let run_function4 lv a0 a1 a2 a3 = run_function lv (P.c4 a0 a1 a2 a3)
    let run_function5 lv a0 a1 a2 a3 a4 = run_function lv (P.c5 a0 a1 a2 a3 a4)
    let run_function6 lv a0 a1 a2 a3 a4 a5 = run_function lv (P.c6 a0 a1 a2 a3 a4 a5)
    let run_function7 lv a0 a1 a2 a3 a4 a5 a6 = run_function lv (P.c7 a0 a1 a2 a3 a4 a5 a6)
    let run_function8 lv a0 a1 a2 a3 a4 a5 a6 a7 = run_function lv (P.c8 a0 a1 a2 a3 a4 a5 a6 a7)
    let run_function9 lv a0 a1 a2 a3 a4 a5 a6 a7 a8 = run_function lv (P.c9 a0 a1 a2 a3 a4 a5 a6 a7 a8)
    let run_function10 lv a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 = run_function lv (P.c10 a0 a1 a2 a3 a4 a5 a6 a7 a8 a9)
  end
  
  module Function = struct
    let lookup n = Option.map ~f:P.unsafe (Llvm.lookup_function n module_)
    let declare n ty = P.unsafe (Llvm.declare_function n !<ty module_)
  end
  
  module External = struct
    let declare cname (l_ret : 'a typ) (l_args : 'b typs) : (('b -> 'a) pointer) v =
      P.unsafe (Llvm.declare_function cname !<(function_ l_ret l_args) module_)
  
    let declare_var_arg cname (l_ret : 'a typ) (l_args : 'b typs) : (('b -> dots -> 'a) pointer) v =
      P.unsafe (Llvm.declare_function cname !<(var_arg_function l_ret l_args) module_)
  
    let malloc = declare "malloc" (pointer_void) (P.c1 i32)
    let free = declare "free" void (P.c1 (pointer_void))
    let memcpy = declare "memcpy" (pointer_void) (P.c3 (pointer_void) (pointer_void) i32)
    let printf = declare_var_arg "printf" i32 (P.c1 (pointer i8))
    let bzero = declare "bzero" void (P.c2 (pointer_void) i32)
  end
  
  module PassManager = struct
    let run_function_if_opt lv = if opt then ignore (Llvm.PassManager.run_function !<lv fpm : bool);
  end
  
end