1. camlspotter
  2. ocaml-llvm-phantom

Commits

camlspotter  committed 2c51a49

removed lbuilder2

  • Participants
  • Parent commits a752532
  • Branches default

Comments (0)

Files changed (3)

File lbuilder2.ml

  • Ignore whitespace
-open Spotlib.Spot
-
-module Make(Module : Lmodule_intf.S) = struct
-  module Type = Ltype.Make(Module)
-  module Value = Lvalue.Make(Module)
-  open Type
-  open Value
-
-  open Module
-
-  let builder = Llvm.builder context
-
-  let call 
-      ?(name="called") (* CR jfuruse: called + f's name *)
-      (f : ('args -> 'ret) pointer v)
-      (args : 'args vs)
-      : 'ret v = 
-    unsafe (Llvm.build_call !=<f (Value.to_array args) name builder)
-
-  let call_va_args
-      ?(name="called")
-      (f : ('args -> dots -> 'ret) pointer v)
-      (args : 'args vs)
-      (va_args : unknown v list)
-      : 'ret v = 
-    unsafe (Llvm.build_call !=<f (Array.of_list (Value.to_list args 
-                                                 @ List.map (!=<) va_args)) name builder)
-
-  let global_stringptr ?(name="stringptr") str : i8 pointer v = 
-    unsafe (Llvm.build_global_stringptr str name builder)
-
-  let bitcast 
-      ?(name="bitcast") 
-      (v : 'a v) 
-      (ty : 'ty typ)
-      : 'ty v = 
-    unsafe (Llvm.build_bitcast !=<v !:<ty name builder)
-
-  let pointercast 
-      ?(name="pointer")
-      (v : 'a pointer v)
-      (ty : 'ty typ)
-      : 'ty v =
-    unsafe (Llvm.build_pointercast !=<v !:<ty name builder)
-
-  (* unsafe *)
-  let unsafe_gep 
-      ?(name = "gepped")
-      (v : 'a pointer v)
-      (xs : i32 v list)
-      : 'unsafe pointer v = 
-    unsafe (Llvm.build_gep !=<v (Array.of_list (List.map (!=<) xs)) name builder)
-
-  let load 
-      ?(name="loaded")
-      (v : 'ty pointer v)
-      : 'ty v = 
-    unsafe (Llvm.build_load !=<v name builder)
-
-  let store 
-      (x : 'a v)
-      ~dst:(dst : 'a pointer v)
-      : unit = 
-    ignore (Llvm.build_store !=<x !=<dst builder)
-
-  let ret x : unit = ignore (Llvm.build_ret !=<x builder)
-  let ret_void () : unit = ignore (Llvm.build_ret_void builder)
-
-  let phi 
-      ?(name="phi")
-      (lst : ('a v * Llvm.llbasicblock) list)
-      : 'a v =
-    unsafe (Llvm.build_phi (List.map (fun (v, b) -> !=<v, b) lst) name builder)
-
-  let cond_br 
-      (b : bool v)
-      bthen belse
-      : unit
-      = ignore (Llvm.build_cond_br !=<b bthen belse builder)
-
-  let br b = ignore (Llvm.build_br b builder)
-
-  let is_null ?(name="is_null") (lv : 'a pointer v) : bool v = 
-    unsafe (Llvm.build_is_null !=<lv name builder)
-
-  (* CR jfuruse: unfortunately no arith type check is done yet *)      
-  let arith (defname : string) f = 
-    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
-      (unsafe (f !=<x !=<y name builder) : 'a v)
-  let cmp (defname : string) f = 
-    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
-      (unsafe (f !=<x !=<y name builder) : bool v)
-
-  let add ?name = arith "added" Llvm.build_add ?name
-  let sub ?name = arith "subed" Llvm.build_sub ?name
-  let mul ?name = arith "muled" Llvm.build_mul ?name
-  let sdiv ?name = arith "sdived" Llvm.build_sdiv ?name
-  let fadd ?name = arith "fadded" Llvm.build_fadd ?name
-  let fsub ?name = arith "fsubed" Llvm.build_fsub ?name
-  let fmul ?name = arith "fmuled" Llvm.build_fmul ?name
-  let fdiv ?name = arith "fdived" Llvm.build_fdiv ?name
-  let icmp c = cmp "icmped" (Llvm.build_icmp c)
-  let fcmp c = cmp "fcmped" (Llvm.build_fcmp c)
-
-  let printf : string -> unknown v list -> unit = 
-    fun fmt args ->
-      let fmt = global_stringptr ~name:"fmt" fmt in
-      ignore (call_va_args (Module.External.printf) (Value.c1 fmt) args ~name:"res")
-  ;;
-
-  let cast_name v lty =
-    let name = Value.name v in
-    let name = try String.sub name 0 (String.rindex name '=') with Not_found -> name in
-    name ^ "=" ^ Type.string_of lty
-
-  (* CR: bitcast is wrapped again! *)
-  let bitcast ?name v lty = 
-    let name = match name with
-      | Some n -> n
-      | None -> cast_name v lty
-    in
-    bitcast ~name v lty
-
-  (* CR pointercast is wrapped again! *)
-  let pointercast ?name v lty = 
-    let name = match name with
-      | Some n -> n
-      | None -> cast_name v lty
-    in
-    pointercast ~name v lty
-
-  let bzero dst ~size = ignore (call Module.External.bzero (Value.c2 dst size))
-
-  let malloc : ?name:string -> ?bzero:bool -> i32 v -> void_pointer v =
-    fun ?(name="alloced") ?bzero:(zero=false) size ->
-      let ptr = call ~name Module.External.malloc (Value.c1 size) in
-      if zero then bzero ptr ~size;
-      ptr
-  ;;
-
-  let malloc_lty ?name ?bzero (lty : 'ty typ) = 
-    bitcast (malloc ?name ?bzero (size_of lty)) (pointer lty)
-
-  let memcpy ~dst ~src ~size = call ~name:"copied" Module.External.memcpy (Value.c3 dst src size)
-
-  let free ptr = ignore (call Module.External.free (Value.c1 ptr))
-  ;;
-
-  let unsafe_const_load ?name ptr indices = 
-    let gepped = unsafe_gep ~name:"for_load" ptr (List.map Const.i32_of_int indices) in
-    load ?name gepped
-
-  (* opposite order! *)
-  let unsafe_const_store ptr indices lv = 
-    let gepped = unsafe_gep ~name:"for_store" ptr (List.map Const.i32_of_int indices) in
-    ignore (store lv ~dst:gepped)
-
-  module Block = struct
-    let position_at_end v = Llvm.position_at_end v builder
-    let insertion () = Llvm.insertion_block builder
-
-    (* They are independent from the builder *) 	
-    let append ?(name="block") (v : ('a -> 'b) pointer t) = Llvm.append_block context name !=<v  
-    let parent bb : ('a -> 'b) pointer t = Value.unsafe (Llvm.block_parent bb)
-  end
-
-  let func name (lty_return : 'ret typ) (args : 'args Ltype.Base.WithString.ts) f : ('args -> 'ret) pointer v =
-    Format.eprintf "Creating function %s@." name;
-    let lty = function_ lty_return (Ltype.Base.WithString.types args) in
-    let lv_f = match Module.Function.lookup name with
-      | Some _ -> failwithf "LLib.create_fun: function %s is defined more than once" name
-      | None -> Module.Function.declare name lty
-    in
-    (* name args *)
-    List.iter2 (fun lv_param name ->
-      Value.set_name name lv_param) 
-      (Value.to_unknown_list (function_params lv_f))
-      (Ltype.Base.WithString.tags args);
-    let bb = Block.append ~name:"entry" lv_f in
-    Block.position_at_end bb;
-    let lv_body = f (function_params lv_f) in
-    (* Finish off the function. *)
-    ret lv_body;
-    (* Validate the generated code, checking for consistency. *)
-    Value.dump lv_f;
-    Analysis.assert_valid_function lv_f;
-    (* Optimize the function *)
-    Module.PassManager.run_function_if_opt lv_f;
-    Format.eprintf "Created function %s@." name;
-    lv_f
-
-  let return_void () : void v = magic Const.i32_0
-    (* The return value looks strange but probably ok. Probably. *)
-
-  let if_then_else (f_lv_cond : unit -> bool v) (f_lv_then : unit -> 'a v) (f_lv_else : unit -> 'a v) : 'a v = 
-    (* get the current bb *)
-    let start_bb = Block.insertion () in
-    (* get the function being defined *)
-    let the_function = Block.parent start_bb in
-    let lv_cond = f_lv_cond () in (* created in [start_bb] *)
-    (* before adding branching, we must create the destinations *)
-
-    let then_bb = Block.append ~name:"then" the_function in
-    (* Emit 'then' value. *)
-    Block.position_at_end then_bb;
-    let lv_then = f_lv_then () in
-    (* Codegen of 'then' can change the current block, update then_bb for the
-     * phi. We create a new name because one is used for the phi node, and the
-     * other is used for the conditional branch. *)
-    let new_then_bb = Block.insertion () in
-
-    let else_bb = Block.append ~name:"else" the_function in
-    (* Emit 'else' value. *)
-    Block.position_at_end else_bb;
-    let lv_else = f_lv_else () in
-    (* Codegen of 'else' can change the current block, update else_bb for the
-     * phi. We create a new name because one is used for the phi node, and the
-     * other is used for the conditional branch. *)
-    let new_else_bb = Block.insertion () in
-
-    (* Emit merge block. *)
-    let merge_bb = Block.append ~name:"ifcont" the_function in
-    Block.position_at_end merge_bb;
-    let incoming = [(lv_then, new_then_bb); (lv_else, new_else_bb)] in
-    (* Llvm.build_phi returns the merged value, which can be used the
-     return of the entire (if ...) *)
-    let phi = phi incoming ~name:"iftmp" in
-
-    (* Return to the start block to add the conditional branch. *)
-    Block.position_at_end start_bb;
-    ignore (cond_br lv_cond then_bb else_bb);
-
-    (* Set a unconditional branch at the end of the 'then' block and the
-     * 'else' block to the 'merge' block. *)
-    Block.position_at_end new_then_bb;
-    ignore (br merge_bb);
-
-    Block.position_at_end new_else_bb;
-    ignore (br merge_bb);
-
-    (* Finally, set the G.builder to the end of the merge block. *)
-    Block.position_at_end merge_bb;
-
-    phi
-
-  let exec =
-    let cntr = ref 0 in
-    fun (v : unit -> unit) ->
-      incr cntr;
-      let name = Printf.sprintf "lbuilder.exec%d" !cntr in
-      Format.eprintf "Executing %s...@." name;
-      let f : (unit -> void) pointer v =
-        let proto = function_ void Type.c0 in
-        match Module.Function.lookup name with
-        | Some _ -> failwithf "function %s is defined more than once" name
-        | None -> Module.Function.declare name proto
-      in
-      prerr_endline "proto done";
-      (* Create a new basic block to start insertion into. *)
-      let bb = Block.append ~name:"entry" f in
-      Block.position_at_end bb;
-      v (); (* create the code *)
-      ret_void ();
-      (* Optimize the function *)
-      Value.dump f;
-      Module.PassManager.run_function_if_opt f;
-      Analysis.assert_valid_function f;
-      Format.eprintf "Now running %s@." name;
-      ignore (Module.ExecutionEngine.run_function f [||]);
-      Format.eprintf "Done running %s@." name;
-end

File lbuilder2.mli

  • Ignore whitespace
-module Make(Module : Lmodule_intf.S) : Lbuilder2_intf.S

File lbuilder2_intf.ml

  • Ignore whitespace
-open Spotlib.Spot
-open Ltype.Base
-open Lvalue.Base
-
-module type S = sig
-  val builder : Llvm.llbuilder
-
-  val call : ?name:string -> ('a -> 'b) pointer v -> 'a vs -> 'b v
-  val call_va_args : ?name: string -> ('a -> dots -> 'b) pointer v -> 'a vs -> unknown v list -> 'b v
-
-  val global_stringptr : ?name:string -> string -> i8 pointer v
-
-  val unsafe_gep : ?name:string -> 'a pointer v -> i32 v list -> 'unsafe pointer v
-    
-  val load : ?name:string -> 'a pointer v -> 'a v
-  val store : 'a v -> dst:'a pointer v -> unit
-    
-  val ret : 'a v -> unit
-  val ret_void : unit -> unit
-    
-  val phi : ?name:string -> ('a v * Llvm.llbasicblock) list -> 'a v
-
-  val cond_br : bool v -> Llvm.llbasicblock -> Llvm.llbasicblock -> unit
-
-  val br : Llvm.llbasicblock -> unit
-
-  val is_null : ?name:string -> 'a pointer v -> bool v
-
-  val add :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v
-  val sub :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v
-  val mul :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v
-  val sdiv : ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v
-  val fadd : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v
-  val fsub : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v
-  val fmul : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v
-  val fdiv : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v
-  val icmp : Llvm.Icmp.t -> ?name:string -> ([>`int] as 'a) v -> 'a v -> bool v
-  val fcmp : Llvm.Fcmp.t -> ?name:string -> ([>`floating] as 'a) v -> 'a v -> bool v
-
-  val printf : string -> unknown v list -> unit
-
-  val bitcast : ?name:string -> 'a v -> 'b typ -> 'b v
-  val pointercast : ?name:string -> 'a pointer v -> ([>`int] as 'b) typ -> 'b v
-
-  val malloc : ?name:string -> ?bzero:bool -> i32 v -> void_pointer v
-  val malloc_lty : ?name:string -> ?bzero:bool -> 'a typ -> 'a pointer v
-  val memcpy : dst:void_pointer v -> src:void_pointer v -> size:i32 v -> void_pointer v
-  val bzero : void_pointer v -> size:i32 v -> unit
-  val free : void_pointer v -> unit
-  val unsafe_const_load : ?name:string -> 'a pointer v -> int list -> 'unsafe v
-  val unsafe_const_store : 'a pointer v -> int list -> 'unsafe v -> unit
-
-  module Block : sig
-    val position_at_end : Llvm.llbasicblock -> unit
-    val insertion : unit -> Llvm.llbasicblock
-    val append : ?name:string -> ('a -> 'b) pointer v -> Llvm.llbasicblock
-    val parent : Llvm.llbasicblock -> ('a -> 'b) pointer v
-  end
-
-  val func : string -> 'a typ -> 'b Ltype.Base.WithString.ts -> ('b vs -> 'a v) -> ('b -> 'a) pointer v
-  val return_void : unit -> void v 
-    (** for functions returning void *)
-  val if_then_else : (unit -> bool v) -> (unit -> 'a v) -> (unit -> 'a v) -> 'a v
-
-  val exec : (unit -> unit) -> unit
-end