Commits

camlspotter committed 425c67b

builder => build

  • Participants
  • Parent commits 34d26bb

Comments (0)

Files changed (9)

    value_ctxt
    module_intf
    module
-   builder_intf
-   builder
+   build_intf
+   build
    wrap_intf
    wrap
    genvalue
+open Spotlib.Spot
+module P = Spotlib.Spot.Phantom
+open P.Open
+
+module Builder = struct
+  include Monad.Make(struct
+    type 'a t = Llvm.llbuilder -> 'a
+    let bind a f = fun builder ->
+      let a = a builder in
+      f a builder
+    let return a = fun _builder -> a
+  end)
+end
+open Builder.Open
+
+module Make(Module : Module_intf.S) = struct
+  module Type = Type_ctxt.Make(Module)
+  module Value = Value_ctxt.Make(Module)
+  open Type
+  open Value
+
+  module Module = Module
+
+  let create () = Llvm.builder Module.context
+
+  (* CR jfuruse: Builder is independent from Module. It can be somewhere else. *)
+  module Monad = struct
+    include Builder
+    let run v = v (create ())
+  end
+
+  type 'a m = 'a Monad.t
+
+  let build = Monad.run
+
+  let unknownM (v : 'a v m) : unknown v m = 
+    v >>= fun v -> return (!?v)
+    
+  let magicM (v : 'a v m) : 'b v m = perform
+    v <-- v;
+    return (P.magic v)
+
+  let unsafeM v = perform
+    v <-- v;
+    return (P.unsafe v)
+
+  let call 
+      ?(name="called") (* CR jfuruse: called + f's name *)
+      (f : ('args -> 'ret) pointer v)
+      (args : 'args vs)
+      : 'ret v m = 
+    (* If its return type is void, we erase the name *)
+    let name = 
+      match classify (function_return (element (type_of f))) with
+      | Llvm.TypeKind.Void -> ""
+      | _ -> name
+    in
+    unsafeM (Llvm.build_call !<f (P.List.to_array args) name)
+
+  let call_va_args
+      ?(name="called")
+      (f : ('args -> dots -> 'ret) pointer v)
+      (args : 'args vs)
+      (va_args : unknown v list)
+      : 'ret v m = 
+    let name = 
+      match classify (function_return (element (type_of f))) with
+      | Llvm.TypeKind.Void -> ""
+      | _ -> name
+    in
+    unsafeM (Llvm.build_call !<f (Array.of_list (P.List.to_list args 
+                                            @ List.map (!<) va_args)) name)
+
+  let global_stringptr ?(name="stringptr") str : i8 pointer v m = 
+    unsafeM (Llvm.build_global_stringptr str name)
+
+  let bitcast 
+      ?(name="bitcast") 
+      (v : 'a v) 
+      (ty : 'ty typ)
+      : 'ty v m = 
+    unsafeM (Llvm.build_bitcast !<v !<ty name)
+
+  let pointercast 
+      ?(name="pointer")
+      (v : 'a pointer v)
+      (ty : 'ty typ)
+      : 'ty v m =
+    unsafeM (Llvm.build_pointercast !<v !<ty name)
+
+  let load 
+      ?(name="loaded")
+      (v : 'ty pointer v)
+      : 'ty v m = 
+    unsafeM (Llvm.build_load !<v name)
+
+  let store 
+      (x : 'a v)
+      ~dst:(dst : 'a pointer v)
+      : unit m = 
+    Monad.ignore (Llvm.build_store !<x !<dst)
+
+  (* unsafe *)
+  let unsafe_gep 
+      ?(name = "gepped")
+      (v : 'a pointer v)
+      (xs : i32 v list)
+      : 'unsafe pointer v m = 
+    unsafeM (Llvm.build_gep !<v (Array.of_list (List.map (!<) xs)) name)
+
+  let gep_gen ?name cont v = Gep.gen (fun lst ->
+    let lst = List.map (function
+      | `int n -> Const.i32_of_int n
+      | `llvalue i -> P.unsafe i) lst in
+    perform
+      ptr <-- unsafe_gep ?name v lst;
+    cont ptr)
+
+  let gep ?name v = gep_gen ?name return v
+  let gep_load ?name v = gep_gen (load ?name) v
+  let gep_store x ~dst:v = gep_gen (fun ptr -> store x ~dst:ptr) v
+
+  let ret x : unit m = Monad.ignore (Llvm.build_ret !<x)
+  let ret_void : unit m = Monad.ignore Llvm.build_ret_void
+
+  let phi 
+      ?(name="phi")
+      (lst : ('a v * Llvm.llbasicblock) list)
+      : 'a v m =
+    unsafeM (Llvm.build_phi (List.map (fun (v, b) -> !<v, b) lst) name)
+
+  let cond_br 
+      (b : i1 v)
+      bthen belse
+      : unit m
+      = Monad.ignore (Llvm.build_cond_br !<b bthen belse)
+
+  let br b = Monad.ignore (Llvm.build_br b)
+
+  let is_null ?(name="is_null") (lv : 'a pointer v) : i1 v m = 
+    unsafeM (Llvm.build_is_null !<lv name)
+
+  (* CR jfuruse: unfortunately no arith type check is done yet *)      
+  let arith (defname : string) f = 
+    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
+      (unsafeM (f !<x !<y name) : 'a v m)
+  let cmp (defname : string) f = 
+    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
+      (unsafeM (f !<x !<y name) : i1 v m)
+
+  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 m = 
+    fun fmt args -> perform
+      fmt <-- global_stringptr ~name:"fmt" fmt;
+      Monad.ignore (call_va_args (Module.External.printf) (P.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 memcpy ~dst ~src ~size = call ~name:"copied" Module.External.memcpy (P.c3 dst src size)
+
+  let bzero dst ~size = Monad.ignore (call Module.External.bzero (P.c2 dst size))
+
+  let malloc : ?name:string -> ?bzero:bool -> i32 v -> void_pointer v m =
+    fun ?(name="alloced") ?bzero:(zero=false) size -> perform
+      ptr <-- call ~name Module.External.malloc (P.c1 size);
+      if zero then bzero ptr ~size else return ();
+      return ptr
+  ;;
+
+  let malloc_by_ty ?name ?bzero (lty : 'ty typ) = perform
+    ptr <-- malloc ?name ?bzero (size_of lty);
+    bitcast ptr (pointer lty)
+
+  let free ptr = perform
+    ptr <-- bitcast ptr pointer_void;
+    Monad.ignore (call Module.External.free (P.c1 ptr))
+  ;;
+
+  let unsafe_const_load ?name ptr indices = perform
+    gepped <-- unsafe_gep ~name:"for_load" ptr (List.map Const.i32_of_int indices);
+    load ?name gepped
+
+  (* opposite order! *)
+  let unsafe_const_store ptr indices lv = perform
+      gepped <-- unsafe_gep ~name:"for_store" ptr (List.map Const.i32_of_int indices);
+      Monad.ignore (store lv ~dst:gepped)
+
+  module Block = struct
+    let position_at_end = Llvm.position_at_end
+    let insertion = Llvm.insertion_block
+
+    (* They are independent from the builder *) 	
+    let append ?(name="block") (v : ('a -> 'b) pointer v) = Llvm.append_block Module.context name !<v  
+    let parent bb : ('a -> 'b) pointer v = P.unsafe (Llvm.block_parent bb)
+  end
+
+  let func name (ty_ret : 'ret typ) (args : ('args, (string * Llvm.lltype)) P.ts) 
+      ?(dump=false)
+      (f : ('args -> 'ret) pointer v -> 'args vs -> 'ret v m) : ('args -> 'ret) pointer v m =
+    (* Format.eprintf "Creating function %s@." name; *)
+    let lty = function_ ty_ret (P.List.map snd 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) 
+      (P.List.to_unknown_list (function_params lv_f))
+      (P.List.to_list (P.List.map fst args));
+    let bb = Block.append ~name:"entry" lv_f in
+    perform 
+      Block.position_at_end bb;
+      lv_body <-- f lv_f (function_params lv_f);
+      (* Finish off the function. *)
+      if classify ty_ret = Llvm.TypeKind.Void then ret_void else ret lv_body;
+      (* Validate the generated code, checking for consistency. *)
+      \ if dump then 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; *)
+      return lv_f
+
+  let return_void : void v m = (fun _builder -> P.magic Const.i32_0)
+    (* The return value looks strange but probably ok. Probably. *)
+
+  (* stupid lambda abstraction is required for polymorphism *)    
+  let current_function : unit -> ('a -> 'b) pointer v m = fun () -> perform
+    current_bb <-- Block.insertion;
+    return (Block.parent current_bb)
+
+  let append_code_block name (codegen : 'a m) : (Llvm.llbasicblock * 'a * Llvm.llbasicblock) m = perform
+    the_function <-- current_function ();
+    let bb = Block.append ~name the_function in
+    (* Emit value. *)
+    Block.position_at_end bb;
+    res <-- codegen;
+    (* Codegen of [res] can change the current block, update bb for the phi. *)
+    new_bb <-- Block.insertion;
+    return (bb, res, new_bb)
+
+  let uncond_br from to_ = perform
+    Block.position_at_end from;
+    Monad.ignore (br to_)
+
+  let if_then_else (lv_cond : i1 v m) (lv_then : 'a v m) (lv_else : 'a v m) : 'a v m = perform
+    (* get the current bb *)
+    start_bb <-- Block.insertion;
+
+    lv_cond <-- lv_cond; (* created in [start_bb] *)
+    (* before adding branching, we must create the destinations *)
+
+    (then_bb, lv_then, new_then_bb) <-- append_code_block "then" lv_then;
+    (else_bb, lv_else, new_else_bb) <-- append_code_block "else" lv_else;
+
+    (* merge_bb and new_merge_bb should be the same *)
+    (merge_bb, phi, new_merge_bb) <-- append_code_block "ifcont" begin
+      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 ...) *)
+      phi incoming ~name:"iftmp"
+    end;
+
+    (* Return to the start block to add the conditional branch. *)
+    Block.position_at_end start_bb;
+    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. *)
+    uncond_br new_then_bb merge_bb;
+    uncond_br new_else_bb merge_bb;
+
+    (* Finally, set the G.builder to the end of the merge block. *)
+    Block.position_at_end new_merge_bb;
+
+    return phi
+
+  let imp_if_then_else (lv_cond : i1 v m) (lv_then : unit m) (lv_else : unit m) : unit m = perform
+    (* get the current bb *)
+    start_bb <-- Block.insertion;
+
+    lv_cond <-- lv_cond; (* created in [start_bb] *)
+    (* before adding branching, we must create the destinations *)
+
+    (then_bb, (), new_then_bb) <-- append_code_block "then" lv_then;
+    (else_bb, (), new_else_bb) <-- append_code_block "else" lv_else;
+
+    (* merge_bb and new_merge_bb should be the same *)
+    (merge_bb, (), new_merge_bb) <-- append_code_block "ifcont" (return ());
+
+    (* Return to the start block to add the conditional branch. *)
+    Block.position_at_end start_bb;
+    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. *)
+    uncond_br new_then_bb merge_bb;
+    uncond_br new_else_bb merge_bb;
+
+    (* Finally, set the G.builder to the end of the merge block. *)
+    Block.position_at_end new_merge_bb;
+
+    return ()
+
+  let for_loop 
+      (init : 'a v) (* initialization of the loop variable of type 'a v *)
+      (cond : 'a v -> i1 v m) (* test on the loop variable *)
+      (do_ : 'a v -> 'a v m) (* do the job and update the loop variable *) = perform
+    start_bb <-- Block.insertion;
+    current_function <-- current_function ();
+
+    (phi_enter, phi, phi_exit) <-- append_code_block "phi" (
+      perform
+        let incoming = [(init, start_bb)] in (* do is not prepared. Added later. *)
+        phi incoming ~name:"fortmp");
+
+    (do_enter,   do_,  do_exit)   <-- append_code_block "do" (do_ phi);
+    \ Llvm.add_incoming (!<do_, do_exit) !<phi; (* now we can add the other incoming *)
+
+    let exit_bb = Block.append ~name:"exit" current_function in
+
+    (cond_enter, _cond, _cond_exit) <-- append_code_block "cond" (perform
+      cond <-- cond phi;
+      cond_br cond do_enter exit_bb;
+      return cond);
+
+    uncond_br start_bb phi_enter;
+    uncond_br do_exit phi_enter;
+    uncond_br phi_exit cond_enter;
+
+    Block.position_at_end exit_bb;
+
+    return ()
+
+  let exec =
+    let cntr = ref 0 in
+    fun (v : unit m) ->
+      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 P.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. *)
+      Monad.run (perform
+        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 P.c0);
+      Format.eprintf "Done running %s@." name;
+end
+module Make(Module : Module_intf.S) : Build_intf.S

File build_intf.ml

+open Spotlib.Spot
+open Spotlib.Spot.Phantom.Open
+open Type
+open Value
+
+module type S = sig
+
+  (** Monad for builder *)    
+  module Monad : sig
+    include Monad_intf.T with type 'a t = Llvm.llbuilder -> 'a
+    val run : 'a t -> 'a
+  end
+  type 'a m = 'a Monad.t
+
+  val build : 'a m -> 'a
+    (** [build m] runs the code gen store in the monad [m] *)
+
+  (** Lifted value coercions *)      
+  val unknownM : 'a v m -> unknown v m
+  val magicM : 'a v m -> 'b v m
+
+  val call : ?name:string -> ('a -> 'b) pointer v -> 'a vs -> 'b v m
+  val call_va_args : ?name: string -> ('a -> dots -> 'b) pointer v -> 'a vs -> unknown v list -> 'b v m
+
+  val global_stringptr : ?name:string -> string -> i8 pointer v m
+
+  val unsafe_gep : ?name:string -> 'a pointer v -> i32 v list -> 'unsafe pointer v m
+    
+  (** Type-safe GEP
+      
+      Do not be fooled by those complex types. They are pretty easy to use:
+
+      [gep v acc1 acc2 ... accn Gep.end_] provides a type safe version of 
+      [unsafe_gep v [<acc1>; <acc2>; .. ; <accn>]].
+
+      Here acci is an accessor, one of the followings:
+       - [Gep.pos n] : Accessing n-th pointer/array/vector elements
+       - [Gep.pos_i32 n] : Accessing n-th pointer/array/vector elements by llvalue
+       - [Gep.mem<i>] : Accessing n-th element of struct
+
+      You must give appropriate accessors: 
+      for example, you cannot use [pos n] for n-th element of struct.
+
+      Do not forget to put Gep.end_ at the end of the accessor list.
+
+      Examples:
+
+        - Obtain i32* from i32[20]* p, which points to p[0][n]
+            gep pointer (Gep.pos_const 0) (Gep.pos n) Gep.end_ : i32 pointer v m
+        - Obtain i32* from {i1, i16, i32, i64}* p, which points to the i32 element of the struct *p.
+            gep pointer (Gep.pos_const 0) Gep.mem2 Gep.end_ : i32 pointer v m
+
+      Type-safe GEP + load/store
+
+      GEP and load/store are often used in conjunctions, gep_load and gep_store are available for such cases:
+
+        - Load i32 p[0][n] of i32[20]* p
+            gep_load pointer (Gep.pos_const 0) (Gep.pos n) Gep.end_ : i32 v m 
+        - Store the i32 element [v] to the 2nd element of {i1, i16, i32, i64}* p
+            gep_store v ~dst:pointer (Gep.pos_const 0) Gep.mem2 Gep.end_ : i32 v m 
+  *)
+  val gep : ?name:string 
+            -> 'a pointer v
+            -> (('a pointer, 'x, 'x pointer v m) Gep.t -> 'b)
+            -> 'b
+  val gep_load : ?name:string 
+            -> 'a pointer v
+            -> (('a pointer, 'x, 'x v m) Gep.t -> 'b)
+            -> 'b
+  val gep_store : 'x v
+            -> dst:'a pointer v
+            -> (('a pointer, 'x, unit m) Gep.t -> 'b)
+            -> 'b
+
+  val load : ?name:string -> 'a pointer v -> 'a v m
+  val store : 'a v -> dst:'a pointer v -> unit m
+    
+  val ret : 'a v -> unit m
+  val ret_void : unit m
+    
+  val phi : ?name:string -> ('a v * Llvm.llbasicblock) list -> 'a v m
+
+  val cond_br : i1 v -> Llvm.llbasicblock -> Llvm.llbasicblock -> unit m
+
+  val br : Llvm.llbasicblock -> unit m
+
+  val is_null : ?name:string -> 'a pointer v -> i1 v m
+
+  val add :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
+  val sub :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
+  val mul :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
+  val sdiv : ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
+  val fadd : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
+  val fsub : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
+  val fmul : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
+  val fdiv : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
+  val icmp : Llvm.Icmp.t -> ?name:string -> ([>`int] as 'a) v -> 'a v -> i1 v m
+  val fcmp : Llvm.Fcmp.t -> ?name:string -> ([>`floating] as 'a) v -> 'a v -> i1 v m
+
+  val printf : string -> unknown v list -> unit m
+    (* CR jfuruse: probably (quite unlikely though), we can have a type safer version *)
+
+  val bitcast : ?name:string -> 'a v -> 'b typ -> 'b v m
+  val pointercast : ?name:string -> 'a pointer v -> ([>`int] as 'b) typ -> 'b v m
+
+  val malloc : ?name:string -> ?bzero:bool -> i32 v -> void_pointer v m
+    (** malloc by size. *)
+
+  val malloc_by_ty : ?name:string -> ?bzero:bool -> 'a typ -> 'a pointer v m
+    (** malloc by type.
+        CR: no nelems available. 
+    *)
+
+  val memcpy : dst:void_pointer v -> src:void_pointer v -> size:i32 v -> void_pointer v m
+  val bzero : void_pointer v -> size:i32 v -> unit m
+  val free : 'a pointer v -> unit m
+
+  val unsafe_const_load : ?name:string -> 'a pointer v -> int list -> 'unsafe v m
+  val unsafe_const_store : 'a pointer v -> int list -> 'unsafe v -> unit m
+
+  module Block : sig
+    val position_at_end : Llvm.llbasicblock -> unit m
+    val insertion : Llvm.llbasicblock m
+    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, (string * Llvm.lltype)) Phantom.ts
+    -> ?dump: bool
+    -> (('b -> 'a) pointer v (* self *) -> 'b vs -> 'a v m) 
+    -> ('b -> 'a) pointer v m
+  (** [func name return_type arg_types ?dump f] defines a function of a name [name] whose type is
+      [arg_types] -> [return_type]. Its function body is defined by [f].
+      Self is for recursion.
+  *)
+
+  val return_void : void v m 
+  (** for functions returning void *)
+
+  val current_function : unit -> ('a -> 'b) pointer v m
+  (** Returns the current function. If not in a function, raises Not_found *) 
+
+  val append_code_block : 
+    string (* name *)
+    -> 'a v m (* codegen *)
+    -> (Llvm.llbasicblock * 'a v * Llvm.llbasicblock) m
+  (** [append_code_block name vm] appends a basicblock of name [name]
+      using the codegen [vm] in the function being defined currently. 
+      It returns the entering block, the codegen result llvalue, and  
+      the exiting block. *)
+
+  val if_then_else : i1 v m -> 'a v m -> 'a v m -> 'a v m
+  (** Functional condition: Not_found is raised if not defined in a function. *)
+
+  val imp_if_then_else : i1 v m -> unit m -> unit m -> unit m
+  (** Imperative condition: Not_found is raised if not defined in a function. *)
+
+  val for_loop : 
+    'a v (* the init loop value *) 
+    -> ('a v -> i1 v m) (* test on the loop value *)
+    -> ('a v -> 'a v m) (* the loop job + loop value update *)
+    -> unit m
+  (** Not_found is raised if not defined in a function *)
+
+  val exec : unit m -> unit
+    (** [exec u] creates an anonymous function from [u] and runs it. *)
+end

File builder.ml

-open Spotlib.Spot
-module P = Spotlib.Spot.Phantom
-open P.Open
-
-module Builder = struct
-  include Monad.Make(struct
-    type 'a t = Llvm.llbuilder -> 'a
-    let bind a f = fun builder ->
-      let a = a builder in
-      f a builder
-    let return a = fun _builder -> a
-  end)
-end
-open Builder.Open
-
-module Make(Module : Module_intf.S) = struct
-  module Type = Type_ctxt.Make(Module)
-  module Value = Value_ctxt.Make(Module)
-  open Type
-  open Value
-
-  module Module = Module
-
-  let create () = Llvm.builder Module.context
-
-  (* CR jfuruse: Builder is independent from Module. It can be somewhere else. *)
-  module Monad = struct
-    include Builder
-    let run v = v (create ())
-  end
-
-  type 'a m = 'a Monad.t
-
-  let build = Monad.run
-
-  let unknownM (v : 'a v m) : unknown v m = 
-    v >>= fun v -> return (!?v)
-    
-  let magicM (v : 'a v m) : 'b v m = perform
-    v <-- v;
-    return (P.magic v)
-
-  let unsafeM v = perform
-    v <-- v;
-    return (P.unsafe v)
-
-  let call 
-      ?(name="called") (* CR jfuruse: called + f's name *)
-      (f : ('args -> 'ret) pointer v)
-      (args : 'args vs)
-      : 'ret v m = 
-    (* If its return type is void, we erase the name *)
-    let name = 
-      match classify (function_return (element (type_of f))) with
-      | Llvm.TypeKind.Void -> ""
-      | _ -> name
-    in
-    unsafeM (Llvm.build_call !<f (P.List.to_array args) name)
-
-  let call_va_args
-      ?(name="called")
-      (f : ('args -> dots -> 'ret) pointer v)
-      (args : 'args vs)
-      (va_args : unknown v list)
-      : 'ret v m = 
-    let name = 
-      match classify (function_return (element (type_of f))) with
-      | Llvm.TypeKind.Void -> ""
-      | _ -> name
-    in
-    unsafeM (Llvm.build_call !<f (Array.of_list (P.List.to_list args 
-                                            @ List.map (!<) va_args)) name)
-
-  let global_stringptr ?(name="stringptr") str : i8 pointer v m = 
-    unsafeM (Llvm.build_global_stringptr str name)
-
-  let bitcast 
-      ?(name="bitcast") 
-      (v : 'a v) 
-      (ty : 'ty typ)
-      : 'ty v m = 
-    unsafeM (Llvm.build_bitcast !<v !<ty name)
-
-  let pointercast 
-      ?(name="pointer")
-      (v : 'a pointer v)
-      (ty : 'ty typ)
-      : 'ty v m =
-    unsafeM (Llvm.build_pointercast !<v !<ty name)
-
-  let load 
-      ?(name="loaded")
-      (v : 'ty pointer v)
-      : 'ty v m = 
-    unsafeM (Llvm.build_load !<v name)
-
-  let store 
-      (x : 'a v)
-      ~dst:(dst : 'a pointer v)
-      : unit m = 
-    Monad.ignore (Llvm.build_store !<x !<dst)
-
-  (* unsafe *)
-  let unsafe_gep 
-      ?(name = "gepped")
-      (v : 'a pointer v)
-      (xs : i32 v list)
-      : 'unsafe pointer v m = 
-    unsafeM (Llvm.build_gep !<v (Array.of_list (List.map (!<) xs)) name)
-
-  let gep_gen ?name cont v = Gep.gen (fun lst ->
-    let lst = List.map (function
-      | `int n -> Const.i32_of_int n
-      | `llvalue i -> P.unsafe i) lst in
-    perform
-      ptr <-- unsafe_gep ?name v lst;
-    cont ptr)
-
-  let gep ?name v = gep_gen ?name return v
-  let gep_load ?name v = gep_gen (load ?name) v
-  let gep_store x ~dst:v = gep_gen (fun ptr -> store x ~dst:ptr) v
-
-  let ret x : unit m = Monad.ignore (Llvm.build_ret !<x)
-  let ret_void : unit m = Monad.ignore Llvm.build_ret_void
-
-  let phi 
-      ?(name="phi")
-      (lst : ('a v * Llvm.llbasicblock) list)
-      : 'a v m =
-    unsafeM (Llvm.build_phi (List.map (fun (v, b) -> !<v, b) lst) name)
-
-  let cond_br 
-      (b : i1 v)
-      bthen belse
-      : unit m
-      = Monad.ignore (Llvm.build_cond_br !<b bthen belse)
-
-  let br b = Monad.ignore (Llvm.build_br b)
-
-  let is_null ?(name="is_null") (lv : 'a pointer v) : i1 v m = 
-    unsafeM (Llvm.build_is_null !<lv name)
-
-  (* CR jfuruse: unfortunately no arith type check is done yet *)      
-  let arith (defname : string) f = 
-    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
-      (unsafeM (f !<x !<y name) : 'a v m)
-  let cmp (defname : string) f = 
-    fun ?(name=defname) (x : 'a v) (y : 'a v) ->
-      (unsafeM (f !<x !<y name) : i1 v m)
-
-  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 m = 
-    fun fmt args -> perform
-      fmt <-- global_stringptr ~name:"fmt" fmt;
-      Monad.ignore (call_va_args (Module.External.printf) (P.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 memcpy ~dst ~src ~size = call ~name:"copied" Module.External.memcpy (P.c3 dst src size)
-
-  let bzero dst ~size = Monad.ignore (call Module.External.bzero (P.c2 dst size))
-
-  let malloc : ?name:string -> ?bzero:bool -> i32 v -> void_pointer v m =
-    fun ?(name="alloced") ?bzero:(zero=false) size -> perform
-      ptr <-- call ~name Module.External.malloc (P.c1 size);
-      if zero then bzero ptr ~size else return ();
-      return ptr
-  ;;
-
-  let malloc_by_ty ?name ?bzero (lty : 'ty typ) = perform
-    ptr <-- malloc ?name ?bzero (size_of lty);
-    bitcast ptr (pointer lty)
-
-  let free ptr = perform
-    ptr <-- bitcast ptr pointer_void;
-    Monad.ignore (call Module.External.free (P.c1 ptr))
-  ;;
-
-  let unsafe_const_load ?name ptr indices = perform
-    gepped <-- unsafe_gep ~name:"for_load" ptr (List.map Const.i32_of_int indices);
-    load ?name gepped
-
-  (* opposite order! *)
-  let unsafe_const_store ptr indices lv = perform
-      gepped <-- unsafe_gep ~name:"for_store" ptr (List.map Const.i32_of_int indices);
-      Monad.ignore (store lv ~dst:gepped)
-
-  module Block = struct
-    let position_at_end = Llvm.position_at_end
-    let insertion = Llvm.insertion_block
-
-    (* They are independent from the builder *) 	
-    let append ?(name="block") (v : ('a -> 'b) pointer v) = Llvm.append_block Module.context name !<v  
-    let parent bb : ('a -> 'b) pointer v = P.unsafe (Llvm.block_parent bb)
-  end
-
-  let func name (ty_ret : 'ret typ) (args : ('args, (string * Llvm.lltype)) P.ts) 
-      ?(dump=false)
-      (f : ('args -> 'ret) pointer v -> 'args vs -> 'ret v m) : ('args -> 'ret) pointer v m =
-    (* Format.eprintf "Creating function %s@." name; *)
-    let lty = function_ ty_ret (P.List.map snd 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) 
-      (P.List.to_unknown_list (function_params lv_f))
-      (P.List.to_list (P.List.map fst args));
-    let bb = Block.append ~name:"entry" lv_f in
-    perform 
-      Block.position_at_end bb;
-      lv_body <-- f lv_f (function_params lv_f);
-      (* Finish off the function. *)
-      if classify ty_ret = Llvm.TypeKind.Void then ret_void else ret lv_body;
-      (* Validate the generated code, checking for consistency. *)
-      \ if dump then 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; *)
-      return lv_f
-
-  let return_void : void v m = (fun _builder -> P.magic Const.i32_0)
-    (* The return value looks strange but probably ok. Probably. *)
-
-  (* stupid lambda abstraction is required for polymorphism *)    
-  let current_function : unit -> ('a -> 'b) pointer v m = fun () -> perform
-    current_bb <-- Block.insertion;
-    return (Block.parent current_bb)
-
-  let append_code_block name (codegen : 'a m) : (Llvm.llbasicblock * 'a * Llvm.llbasicblock) m = perform
-    the_function <-- current_function ();
-    let bb = Block.append ~name the_function in
-    (* Emit value. *)
-    Block.position_at_end bb;
-    res <-- codegen;
-    (* Codegen of [res] can change the current block, update bb for the phi. *)
-    new_bb <-- Block.insertion;
-    return (bb, res, new_bb)
-
-  let uncond_br from to_ = perform
-    Block.position_at_end from;
-    Monad.ignore (br to_)
-
-  let if_then_else (lv_cond : i1 v m) (lv_then : 'a v m) (lv_else : 'a v m) : 'a v m = perform
-    (* get the current bb *)
-    start_bb <-- Block.insertion;
-
-    lv_cond <-- lv_cond; (* created in [start_bb] *)
-    (* before adding branching, we must create the destinations *)
-
-    (then_bb, lv_then, new_then_bb) <-- append_code_block "then" lv_then;
-    (else_bb, lv_else, new_else_bb) <-- append_code_block "else" lv_else;
-
-    (* merge_bb and new_merge_bb should be the same *)
-    (merge_bb, phi, new_merge_bb) <-- append_code_block "ifcont" begin
-      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 ...) *)
-      phi incoming ~name:"iftmp"
-    end;
-
-    (* Return to the start block to add the conditional branch. *)
-    Block.position_at_end start_bb;
-    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. *)
-    uncond_br new_then_bb merge_bb;
-    uncond_br new_else_bb merge_bb;
-
-    (* Finally, set the G.builder to the end of the merge block. *)
-    Block.position_at_end new_merge_bb;
-
-    return phi
-
-  let imp_if_then_else (lv_cond : i1 v m) (lv_then : unit m) (lv_else : unit m) : unit m = perform
-    (* get the current bb *)
-    start_bb <-- Block.insertion;
-
-    lv_cond <-- lv_cond; (* created in [start_bb] *)
-    (* before adding branching, we must create the destinations *)
-
-    (then_bb, (), new_then_bb) <-- append_code_block "then" lv_then;
-    (else_bb, (), new_else_bb) <-- append_code_block "else" lv_else;
-
-    (* merge_bb and new_merge_bb should be the same *)
-    (merge_bb, (), new_merge_bb) <-- append_code_block "ifcont" (return ());
-
-    (* Return to the start block to add the conditional branch. *)
-    Block.position_at_end start_bb;
-    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. *)
-    uncond_br new_then_bb merge_bb;
-    uncond_br new_else_bb merge_bb;
-
-    (* Finally, set the G.builder to the end of the merge block. *)
-    Block.position_at_end new_merge_bb;
-
-    return ()
-
-  let for_loop 
-      (init : 'a v) (* initialization of the loop variable of type 'a v *)
-      (cond : 'a v -> i1 v m) (* test on the loop variable *)
-      (do_ : 'a v -> 'a v m) (* do the job and update the loop variable *) = perform
-    start_bb <-- Block.insertion;
-    current_function <-- current_function ();
-
-    (phi_enter, phi, phi_exit) <-- append_code_block "phi" (
-      perform
-        let incoming = [(init, start_bb)] in (* do is not prepared. Added later. *)
-        phi incoming ~name:"fortmp");
-
-    (do_enter,   do_,  do_exit)   <-- append_code_block "do" (do_ phi);
-    \ Llvm.add_incoming (!<do_, do_exit) !<phi; (* now we can add the other incoming *)
-
-    let exit_bb = Block.append ~name:"exit" current_function in
-
-    (cond_enter, _cond, _cond_exit) <-- append_code_block "cond" (perform
-      cond <-- cond phi;
-      cond_br cond do_enter exit_bb;
-      return cond);
-
-    uncond_br start_bb phi_enter;
-    uncond_br do_exit phi_enter;
-    uncond_br phi_exit cond_enter;
-
-    Block.position_at_end exit_bb;
-
-    return ()
-
-  let exec =
-    let cntr = ref 0 in
-    fun (v : unit m) ->
-      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 P.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. *)
-      Monad.run (perform
-        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 P.c0);
-      Format.eprintf "Done running %s@." name;
-end

File builder.mli

-module Make(Module : Module_intf.S) : Builder_intf.S

File builder_intf.ml

-open Spotlib.Spot
-open Spotlib.Spot.Phantom.Open
-open Type
-open Value
-
-module type S = sig
-
-  (** Monad for builder *)    
-  module Monad : sig
-    include Monad_intf.T with type 'a t = Llvm.llbuilder -> 'a
-    val run : 'a t -> 'a
-  end
-  type 'a m = 'a Monad.t
-
-  val build : 'a m -> 'a
-    (** [build m] runs the code gen store in the monad [m] *)
-
-  (** Lifted value coercions *)      
-  val unknownM : 'a v m -> unknown v m
-  val magicM : 'a v m -> 'b v m
-
-  val call : ?name:string -> ('a -> 'b) pointer v -> 'a vs -> 'b v m
-  val call_va_args : ?name: string -> ('a -> dots -> 'b) pointer v -> 'a vs -> unknown v list -> 'b v m
-
-  val global_stringptr : ?name:string -> string -> i8 pointer v m
-
-  val unsafe_gep : ?name:string -> 'a pointer v -> i32 v list -> 'unsafe pointer v m
-    
-  (** Type-safe GEP
-      
-      Do not be fooled by those complex types. They are pretty easy to use:
-
-      [gep v acc1 acc2 ... accn Gep.end_] provides a type safe version of 
-      [unsafe_gep v [<acc1>; <acc2>; .. ; <accn>]].
-
-      Here acci is an accessor, one of the followings:
-       - [Gep.pos n] : Accessing n-th pointer/array/vector elements
-       - [Gep.pos_i32 n] : Accessing n-th pointer/array/vector elements by llvalue
-       - [Gep.mem<i>] : Accessing n-th element of struct
-
-      You must give appropriate accessors: 
-      for example, you cannot use [pos n] for n-th element of struct.
-
-      Do not forget to put Gep.end_ at the end of the accessor list.
-
-      Examples:
-
-        - Obtain i32* from i32[20]* p, which points to p[0][n]
-            gep pointer (Gep.pos_const 0) (Gep.pos n) Gep.end_ : i32 pointer v m
-        - Obtain i32* from {i1, i16, i32, i64}* p, which points to the i32 element of the struct *p.
-            gep pointer (Gep.pos_const 0) Gep.mem2 Gep.end_ : i32 pointer v m
-
-      Type-safe GEP + load/store
-
-      GEP and load/store are often used in conjunctions, gep_load and gep_store are available for such cases:
-
-        - Load i32 p[0][n] of i32[20]* p
-            gep_load pointer (Gep.pos_const 0) (Gep.pos n) Gep.end_ : i32 v m 
-        - Store the i32 element [v] to the 2nd element of {i1, i16, i32, i64}* p
-            gep_store v ~dst:pointer (Gep.pos_const 0) Gep.mem2 Gep.end_ : i32 v m 
-  *)
-  val gep : ?name:string 
-            -> 'a pointer v
-            -> (('a pointer, 'x, 'x pointer v m) Gep.t -> 'b)
-            -> 'b
-  val gep_load : ?name:string 
-            -> 'a pointer v
-            -> (('a pointer, 'x, 'x v m) Gep.t -> 'b)
-            -> 'b
-  val gep_store : 'x v
-            -> dst:'a pointer v
-            -> (('a pointer, 'x, unit m) Gep.t -> 'b)
-            -> 'b
-
-  val load : ?name:string -> 'a pointer v -> 'a v m
-  val store : 'a v -> dst:'a pointer v -> unit m
-    
-  val ret : 'a v -> unit m
-  val ret_void : unit m
-    
-  val phi : ?name:string -> ('a v * Llvm.llbasicblock) list -> 'a v m
-
-  val cond_br : i1 v -> Llvm.llbasicblock -> Llvm.llbasicblock -> unit m
-
-  val br : Llvm.llbasicblock -> unit m
-
-  val is_null : ?name:string -> 'a pointer v -> i1 v m
-
-  val add :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
-  val sub :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
-  val mul :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
-  val sdiv : ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
-  val fadd : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
-  val fsub : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
-  val fmul : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
-  val fdiv : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v m
-  val icmp : Llvm.Icmp.t -> ?name:string -> ([>`int] as 'a) v -> 'a v -> i1 v m
-  val fcmp : Llvm.Fcmp.t -> ?name:string -> ([>`floating] as 'a) v -> 'a v -> i1 v m
-
-  val printf : string -> unknown v list -> unit m
-    (* CR jfuruse: probably (quite unlikely though), we can have a type safer version *)
-
-  val bitcast : ?name:string -> 'a v -> 'b typ -> 'b v m
-  val pointercast : ?name:string -> 'a pointer v -> ([>`int] as 'b) typ -> 'b v m
-
-  val malloc : ?name:string -> ?bzero:bool -> i32 v -> void_pointer v m
-    (** malloc by size. *)
-
-  val malloc_by_ty : ?name:string -> ?bzero:bool -> 'a typ -> 'a pointer v m
-    (** malloc by type.
-        CR: no nelems available. 
-    *)
-
-  val memcpy : dst:void_pointer v -> src:void_pointer v -> size:i32 v -> void_pointer v m
-  val bzero : void_pointer v -> size:i32 v -> unit m
-  val free : 'a pointer v -> unit m
-
-  val unsafe_const_load : ?name:string -> 'a pointer v -> int list -> 'unsafe v m
-  val unsafe_const_store : 'a pointer v -> int list -> 'unsafe v -> unit m
-
-  module Block : sig
-    val position_at_end : Llvm.llbasicblock -> unit m
-    val insertion : Llvm.llbasicblock m
-    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, (string * Llvm.lltype)) Phantom.ts
-    -> ?dump: bool
-    -> (('b -> 'a) pointer v (* self *) -> 'b vs -> 'a v m) 
-    -> ('b -> 'a) pointer v m
-  (** [func name return_type arg_types ?dump f] defines a function of a name [name] whose type is
-      [arg_types] -> [return_type]. Its function body is defined by [f].
-      Self is for recursion.
-  *)
-
-  val return_void : void v m 
-  (** for functions returning void *)
-
-  val current_function : unit -> ('a -> 'b) pointer v m
-  (** Returns the current function. If not in a function, raises Not_found *) 
-
-  val append_code_block : 
-    string (* name *)
-    -> 'a v m (* codegen *)
-    -> (Llvm.llbasicblock * 'a v * Llvm.llbasicblock) m
-  (** [append_code_block name vm] appends a basicblock of name [name]
-      using the codegen [vm] in the function being defined currently. 
-      It returns the entering block, the codegen result llvalue, and  
-      the exiting block. *)
-
-  val if_then_else : i1 v m -> 'a v m -> 'a v m -> 'a v m
-  (** Functional condition: Not_found is raised if not defined in a function. *)
-
-  val imp_if_then_else : i1 v m -> unit m -> unit m -> unit m
-  (** Imperative condition: Not_found is raised if not defined in a function. *)
-
-  val for_loop : 
-    'a v (* the init loop value *) 
-    -> ('a v -> i1 v m) (* test on the loop value *)
-    -> ('a v -> 'a v m) (* the loop job + loop value update *)
-    -> unit m
-  (** Not_found is raised if not defined in a function *)
-
-  val exec : unit m -> unit
-    (** [exec u] creates an anonymous function from [u] and runs it. *)
-end
       let context = context
     end)
     include M
-    include Builder.Make(M)
+    include Build.Make(M)
   end
 end

File wrap_intf.ml

 
 module type M = sig
   include Module_intf.S
-  include Builder_intf.S
+  include Build_intf.S
 end
 
 module type S = sig