Commits

camlspotter committed 84dd206

module name clean up

  • Participants
  • Parent commits 82bb41b

Comments (0)

Files changed (37)

 OCAMLPPFLAGS= -syntax camlp4o -package monad
 
 FILES[] =
-   ltype_intf
-   ltype
+   type_intf
+   type
    gep
-   lvalue_intf
-   lvalue
-   lmodule_intf
-   lmodule
-   lbuilder_intf
-   lbuilder
-   lwrap_intf
-   lwrap
-   lgenvalue
+   value_intf
+   value
+   module_intf
+   module
+   builder_intf
+   builder
+   wrap_intf
+   wrap
+   genvalue
 
 OCAML_LIBS +=
 OCAML_CLIBS +=
+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.Make(Module)
+  module Value = Value.Make(Module)
+  open Type
+  open Value
+
+  module Module = Module
+  open Module
+
+  let create () = Llvm.builder context
+
+  module Monad = struct
+    include Builder
+    let run v = v (create ())
+  end
+
+  type 'a m = 'a Monad.t
+
+  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.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.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)
+
+  module Gep = struct
+    include Gep
+    let gen ?name cont v = 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 pos x = pos !<x
+  end
+
+  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 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) 
+      (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 (Type.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) 
+      (P.to_unknown_list (function_params lv_f))
+      (Type.WithString.tags 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. *)
+      \ 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 [||]);
+      Format.eprintf "Done running %s@." name;
+end
+module Make(Module : Module_intf.S) : Builder_intf.S

File builder_intf.ml

+open Spotlib.Spot
+open Type
+open Value
+
+open Spotlib.Spot.Phantom
+
+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
+
+  (** 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_const n] : Accessing n-th pointer/array/vector elements
+       - [Gep.pos 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 
+  *)
+  module Gep : sig
+    type ('a, 'final, 'res) t
+    val end_ : ('a, 'a, 'res m) t -> 'res m
+    val pos_const : int -> ([> `container of 'a], 'final, 'res) t -> (('a, 'final, 'res) t -> 'b) -> 'b
+    val pos : i32 v -> ([> `container of 'a], 'final, 'res) t -> (('a, 'final, 'res) t -> 'b) -> 'b
+    val mem0 : (('a0 * _) struct_, 'final, 'res) t -> (('a0, 'final, 'res) t -> 'b) -> 'b
+    val mem1 : ((_ * ('a1 * _)) struct_, 'final, 'res) t -> (('a1, 'final, 'res) t -> 'b) -> 'b
+    val mem2 : ((_ * (_ * ('a2 * _))) struct_, 'final, 'res) t -> (('a2, 'final, 'res) t -> 'b) -> 'b
+    val mem3 : ((_ * (_ * (_ * ('a3 * _)))) struct_, 'final, 'res) t -> (('a3, 'final, 'res) t -> 'b) -> 'b
+    val mem4 : ((_ * (_ * (_ * (_ * ('a4 * _))))) struct_, 'final, 'res) t -> (('a4, 'final, 'res) t -> 'b) -> 'b
+    val mem5 : ((_ * (_ * (_ * (_ * (_ * ('a5 * _)))))) struct_, 'final, 'res) t -> (('a5, 'final, 'res) t -> 'b) -> 'b
+    val mem6 : ((_ * (_ * (_ * (_ * (_ * (_ * ('a6 * _))))))) struct_, 'final, 'res) t -> (('a6, 'final, 'res) t -> 'b) -> 'b
+    val mem7 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a7 * _)))))))) struct_, 'final, 'res) t -> (('a7, 'final, 'res) t -> 'b) -> 'b
+    val mem8 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a8 * _))))))))) struct_, 'final, 'res) t -> (('a8, 'final, 'res) t -> 'b) -> 'b
+    val mem9 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a9 * _)))))))))) struct_, 'final, 'res) t -> (('a9, 'final, 'res) t -> 'b) -> 'b
+  end 
+
+  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)) ts
+    -> (('b -> 'a) pointer v (* self *)
+        -> 'b vs -> 'a v m) -> ('b -> 'a) pointer v m
+  (** [func name return_type arg_types 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
+open Spotlib.Spot
+open Llvm
+open Llvm_executionengine
+open Type
+
+open Spotlib.Spot.Phantom
+
+module GV = GenericValue
+
+(** phantom *)
+type 'a v = ('a, GV.t) Phantom.t
+type 'a vs = ('a, GV.t) Phantom.ts
+
+let unsafe_annotate v _t = v
+
+let of_float : ([>`floating] as 'a) typ -> float -> 'a v = 
+  fun ty v -> unsafe ^$ GV.of_float !<ty v
+
+let unsafe_of_pointer : 'a (* unsafe *) -> 'b pointer v = 
+  fun v -> unsafe ^$ GV.of_pointer v
+
+let of_int32 : ([>`int] as 'a) typ -> int32 -> 'a v =
+  fun ty v -> unsafe ^$ GV.of_int32 !<ty v
+
+let of_int : ([>`int] as 'a) typ -> int -> 'a v =
+  fun ty v -> unsafe ^$ GV.of_int !<ty v
+
+let of_nativeint : ([>`int] as 'a) typ -> nativeint -> 'a v =
+  fun ty v -> unsafe ^$ GV.of_nativeint !<ty v
+
+let of_int64 : ([>`int] as 'a) typ -> int64 -> 'a v =
+  fun ty v -> unsafe ^$ GV.of_int64 !<ty v
+
+let as_float : ([>`floating] as 'a) typ -> 'a v -> float = 
+  fun ty v -> GV.as_float !<ty !<v
+let as_unsafe_pointer : 'a pointer v -> 'b (* unsafe *) = fun v -> GV.as_pointer !<v
+let as_int32 : ([>`int] as 'a) v -> int32  = fun v -> GV.as_int32 !<v
+let as_int : ([>`int] as 'a) v -> int = fun v -> GV.as_int !<v
+let as_nativeint : ([>`int] as 'a) v -> nativeint = fun v -> GV.as_nativeint !<v
+let as_int64 : ([>`int] as 'a) v -> int64 = fun v -> GV.as_int64 !<v
+

File genvalue.mli

+open Spotlib.Spot
+open Type
+open Llvm_executionengine
+
+open Spotlib.Spot.Phantom
+
+type 'a v = ('a, GenericValue.t) t 
+type 'a vs = ('a, GenericValue.t) ts
+
+(** phantom *)
+(* val unsafe_annotate : GenericValue.t -> 'a v _t = v *)
+
+val of_float : ([>`floating] as 'a) typ -> float -> 'a v
+val unsafe_of_pointer : 'a (* unsafe *) -> 'b pointer v
+val of_int32 : ([>`int] as 'a) typ -> int32 -> 'a v
+val of_int : ([>`int] as 'a) typ -> int -> 'a v
+val of_nativeint : ([>`int] as 'a) typ -> nativeint -> 'a v
+val of_int64 : ([>`int] as 'a) typ -> int64 -> 'a v
+
+val as_float : ([>`floating] as 'a) typ -> 'a v -> float
+val as_unsafe_pointer : 'a pointer v -> 'b (* unsafe *)
+val as_int32 : ([>`int] as 'a) v -> int32
+val as_int : ([>`int] as 'a) v -> int
+val as_nativeint : ([>`int] as 'a) v -> nativeint
+val as_int64 : ([>`int] as 'a) v -> int64
+
-open Ltype
+open Type
 
 type ('a, 'final, 'res) t = 
     { k : [`int of int | `llvalue of Llvm.llvalue] list -> 'res; 
 (** Type-safe GEP tools *)
 
-open Ltype
+open Type
 
 type ('a, 'final, 'res) t
   (** GEP phantom *)

File lbuilder.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 : Lmodule_intf.S) = struct
-  module Type = Ltype.Make(Module)
-  module Value = Lvalue.Make(Module)
-  open Type
-  open Value
-
-  module Module = Module
-  open Module
-
-  let create () = Llvm.builder context
-
-  module Monad = struct
-    include Builder
-    let run v = v (create ())
-  end
-
-  type 'a m = 'a Monad.t
-
-  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.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.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)
-
-  module Gep = struct
-    include Gep
-    let gen ?name cont v = 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 pos x = pos !<x
-  end
-
-  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 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) 
-      (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 (Ltype.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) 
-      (P.to_unknown_list (function_params lv_f))
-      (Ltype.WithString.tags 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. *)
-      \ 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 [||]);
-      Format.eprintf "Done running %s@." name;
-end

File lbuilder.mli

-module Make(Module : Lmodule_intf.S) : Lbuilder_intf.S

File lbuilder_intf.ml

-open Spotlib.Spot
-open Ltype
-open Lvalue
-
-open Spotlib.Spot.Phantom
-
-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
-
-  (** 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_const n] : Accessing n-th pointer/array/vector elements
-       - [Gep.pos 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 
-  *)
-  module Gep : sig
-    type ('a, 'final, 'res) t
-    val end_ : ('a, 'a, 'res m) t -> 'res m
-    val pos_const : int -> ([> `container of 'a], 'final, 'res) t -> (('a, 'final, 'res) t -> 'b) -> 'b
-    val pos : i32 v -> ([> `container of 'a], 'final, 'res) t -> (('a, 'final, 'res) t -> 'b) -> 'b
-    val mem0 : (('a0 * _) struct_, 'final, 'res) t -> (('a0, 'final, 'res) t -> 'b) -> 'b
-    val mem1 : ((_ * ('a1 * _)) struct_, 'final, 'res) t -> (('a1, 'final, 'res) t -> 'b) -> 'b
-    val mem2 : ((_ * (_ * ('a2 * _))) struct_, 'final, 'res) t -> (('a2, 'final, 'res) t -> 'b) -> 'b
-    val mem3 : ((_ * (_ * (_ * ('a3 * _)))) struct_, 'final, 'res) t -> (('a3, 'final, 'res) t -> 'b) -> 'b
-    val mem4 : ((_ * (_ * (_ * (_ * ('a4 * _))))) struct_, 'final, 'res) t -> (('a4, 'final, 'res) t -> 'b) -> 'b
-    val mem5 : ((_ * (_ * (_ * (_ * (_ * ('a5 * _)))))) struct_, 'final, 'res) t -> (('a5, 'final, 'res) t -> 'b) -> 'b
-    val mem6 : ((_ * (_ * (_ * (_ * (_ * (_ * ('a6 * _))))))) struct_, 'final, 'res) t -> (('a6, 'final, 'res) t -> 'b) -> 'b
-    val mem7 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a7 * _)))))))) struct_, 'final, 'res) t -> (('a7, 'final, 'res) t -> 'b) -> 'b
-    val mem8 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a8 * _))))))))) struct_, 'final, 'res) t -> (('a8, 'final, 'res) t -> 'b) -> 'b
-    val mem9 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a9 * _)))))))))) struct_, 'final, 'res) t -> (('a9, 'final, 'res) t -> 'b) -> 'b
-  end 
-
-  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)) ts
-    -> (('b -> 'a) pointer v (* self *)
-        -> 'b vs -> 'a v m) -> ('b -> 'a) pointer v m
-  (** [func name return_type arg_types 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 lgenvalue.ml

-open Spotlib.Spot
-open Llvm
-open Llvm_executionengine
-open Ltype
-
-open Spotlib.Spot.Phantom
-
-module GV = GenericValue
-
-(** phantom *)
-type 'a v = ('a, GV.t) Phantom.t
-type 'a vs = ('a, GV.t) Phantom.ts
-
-let unsafe_annotate v _t = v
-
-let of_float : ([>`floating] as 'a) typ -> float -> 'a v = 
-  fun ty v -> unsafe ^$ GV.of_float !<ty v
-
-let unsafe_of_pointer : 'a (* unsafe *) -> 'b pointer v = 
-  fun v -> unsafe ^$ GV.of_pointer v
-
-let of_int32 : ([>`int] as 'a) typ -> int32 -> 'a v =
-  fun ty v -> unsafe ^$ GV.of_int32 !<ty v
-
-let of_int : ([>`int] as 'a) typ -> int -> 'a v =
-  fun ty v -> unsafe ^$ GV.of_int !<ty v
-
-let of_nativeint : ([>`int] as 'a) typ -> nativeint -> 'a v =
-  fun ty v -> unsafe ^$ GV.of_nativeint !<ty v
-
-let of_int64 : ([>`int] as 'a) typ -> int64 -> 'a v =
-  fun ty v -> unsafe ^$ GV.of_int64 !<ty v
-
-let as_float : ([>`floating] as 'a) typ -> 'a v -> float = 
-  fun ty v -> GV.as_float !<ty !<v
-let as_unsafe_pointer : 'a pointer v -> 'b (* unsafe *) = fun v -> GV.as_pointer !<v
-let as_int32 : ([>`int] as 'a) v -> int32  = fun v -> GV.as_int32 !<v
-let as_int : ([>`int] as 'a) v -> int = fun v -> GV.as_int !<v
-let as_nativeint : ([>`int] as 'a) v -> nativeint = fun v -> GV.as_nativeint !<v
-let as_int64 : ([>`int] as 'a) v -> int64 = fun v -> GV.as_int64 !<v
-

File lgenvalue.mli

-open Spotlib.Spot
-open Ltype
-open Llvm_executionengine
-
-open Spotlib.Spot.Phantom
-
-type 'a v = ('a, GenericValue.t) t 
-type 'a vs = ('a, GenericValue.t) ts
-
-(** phantom *)
-(* val unsafe_annotate : GenericValue.t -> 'a v _t = v *)
-
-val of_float : ([>`floating] as 'a) typ -> float -> 'a v
-val unsafe_of_pointer : 'a (* unsafe *) -> 'b pointer v
-val of_int32 : ([>`int] as 'a) typ -> int32 -> 'a v
-val of_int : ([>`int] as 'a) typ -> int -> 'a v
-val of_nativeint : ([>`int] as 'a) typ -> nativeint -> 'a v
-val of_int64 : ([>`int] as 'a) typ -> int64 -> 'a v
-
-val as_float : ([>`floating] as 'a) typ -> 'a v -> float
-val as_unsafe_pointer : 'a pointer v -> 'b (* unsafe *)
-val as_int32 : ([>`int] as 'a) v -> int32
-val as_int : ([>`int] as 'a) v -> int
-val as_nativeint : ([>`int] as 'a) v -> nativeint
-val as_int64 : ([>`int] as 'a) v -> int64
-

File lmodule.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 : Llvm.llcontext 
-  val name : string
-  val opt : bool
-end) = struct
-  module Type = Ltype.Make(A)
-  module Value = Lvalue.Make(A)
-  open Type
-  open Value
-
-  include A
-
-  let module_ = Llvm.create_module context name
-  
-  (* Create the JIT. *)
-  
-  let engine = E.ExecutionEngine.create module_
-  module ExecutionEngine = struct
-    let run_function (lv : ('a -> 'b) pointer v) args = 
-      E.ExecutionEngine.run_function !<lv args engine
-  end
-  
-  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
-  
-  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 dump module_ = Llvm.dump_module module_
-  
-  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

File lmodule.mli

-module Make(A : sig 
-  val context : Llvm.llcontext 
-  val name : string 
-  val opt : bool
-end) : Lmodule_intf.S

File lmodule_intf.ml

-open Ltype
-open Lvalue
-
-open Spotlib.Spot.Phantom
-
-open Llvm_executionengine (* for GenericValue *)
-
-module type S = sig
-  val context : Llvm.llcontext
-  val name : string
-  val opt : bool
-
-  val module_ : Llvm.llmodule
-
-  val define_type_name : string -> 'a typ -> 'a typ
-  val dump : Llvm.llmodule -> unit
-
-  module ExecutionEngine : sig
-    (* CR: can be more type safe *)
-    val run_function : ('args -> 'ret) pointer v -> GenericValue.t array -> GenericValue.t
-  end
-
-  module Function : sig
-    val lookup : string -> (unknown -> unknown) pointer v option
-    val declare : string -> ('a -> 'b) typ -> ('a -> 'b) pointer v
-  end
-  
-  module External : sig
-    val declare : string -> 'a typ -> 'b typs -> ('b -> 'a) pointer v
-    val declare_var_arg : string -> 'a typ -> 'b typs -> ('b -> dots -> 'a) pointer v
-
-    (** functions from libc *)  
-
-    val malloc : (i32 tpl1 -> void_pointer) pointer v
-    val free : (void_pointer tpl1 -> void) pointer v
-    val memcpy : ((void_pointer, void_pointer, i32) tpl3 -> void_pointer) pointer v
-    val printf : (i8 pointer tpl1 -> dots -> i32) pointer v
-    val bzero : ((void_pointer, i32) tpl2 -> void) pointer v
-  end
-
-  module PassManager : sig 
-    val run_function_if_opt : ('a -> 'b) pointer v -> unit 
-  end
-end

File ltype.ml

-(* llvm type algebra *)
-
-open Llvm
-open Spotlib.Spot
-
-module P = Spotlib.Spot.Phantom
-open P.Open
-
-(** Context Free *)
-module CF = struct
-  (** phantom *)
-  type 'a typ = ('a, lltype) P.t 
-  type 'a typs = ('a, lltype) P.ts
-  
-  (** descriptors *)
-  
-  type void = unit
-  type i1 = [`int | `i1]
-  type i8 = [`int | `i8]
-  type i16 = [`int | `i16]
-  type i32 = [`int | `i32]
-  type i64 = [`int | `i64]
-  type 'a integer
-  (* type float_d *)
-  type double = [`floating | `double]
-  type dots
-  type 'a struct_
-  type ('a, 'tag) array_ = [`array of 'a * 'tag | `container of 'a]
-  type 'a pointer = [`pointer of 'a | `container of 'a]
-  type 'a vector = [`vector of 'a | `container of 'a]
-  
-  (* void pointer is special in LLVM. It is illegal! *)
-  type void_pointer = i8 pointer
-
-  module WithString = struct
-    let tags ts = List.map fst (P.to_list ts)
-    let types (ts : ('a, 'tag * lltype) P.ts) : 'a typs = 
-      P.unsafe_of_list (List.map snd (P.to_list ts))
-    let combine (tags : 'tag list) (ts : 'a typs) : ('a, ('tag * lltype)) P.ts =
-      P.unsafe_of_list (List.combine tags (P.to_list ts))
-    let tag t (v : ('a, lltype) P.t) : ('a, ('tag * lltype)) P.t = P.unsafe (t, !<v)
-  end
-end
-
-include CF
-
-(* This should be shared by all the Make(A) *)
-let defined_names : (lltype * (string * string)) list ref = ref []
-
-(** Extend CF with context dependent functions *)
-module Make(A : sig val context : llcontext end) = struct
-  include A
-
-  include CF
-
-  (* shorter names *)
-  let classify ty = classify_type !<ty
-  
-  let integer c ((_tag : 'itag), x) : 'itag integer typ = P.unsafe ^$ integer_type c x
-  let float c : float typ = P.unsafe ^$ float_type c
-  let double c : double typ = P.unsafe ^$ double_type c
-  let function_ : 'ret typ -> 'args typs -> ('args -> 'ret) typ = fun ret args -> P.unsafe ^$ function_type !<ret (P.to_array args)
-  let var_arg_function : 'ret typ -> 'args typs -> ('args -> dots -> 'ret) typ = fun ret args -> P.unsafe ^$ var_arg_function_type !<ret (P.to_array args)
-
-  (* CR jfuruse: not for dots !*)
-  let function_params (t : ('args -> 'ret) typ) : 'args typs = P.unsafe_of_array (param_types !<t)
-  let function_return (ty : ('args -> 'ret) typ) : 'ret typ = P.unsafe ^$ return_type !<ty
-
-  let struct_ c (args : 'args typs) : 'args struct_ typ = P.unsafe ^$ struct_type c (P.to_array args)
-(*
-  let check_struct t = match classify t with
-    | TypeKind.Struct -> t
-    | _ -> assert false
-*)
-  
-  let struct_elements (t : 'typs struct_ typ) : 'typs typs = P.unsafe_of_array (struct_element_types !<t)
-  let array_ (t : 't typ) ((_tag : 'itag), size) : ('t, 'itag) array_ typ = P.unsafe ^$ array_type !<t size
-    
-  let pointer (t : 't typ) : 't pointer typ = P.unsafe ^$ pointer_type !<t
-(*
-  let check_pointer t = match classify t with
-    | TypeKind.Pointer _ -> t
-    | _ -> assert false
-*)
-  let element (t : [>`container of 't] typ) : 't typ = P.unsafe ^$ element_type !<t
-
-  let define_name ~modname n t =
-    Format.eprintf "Registered named type %s.%s@." modname n;
-    defined_names := (!<t, (modname, n)) :: !defined_names
-
-  (** [string_of_lltype] of LLVM 2.8 has a bug: if it tries to print a recursive type, cabooom! *)        
-  (* Here is a fix *)        
-  let string_of_lltype ty =
-    let create_name =
-      let cntr = ref 0 in
-      fun () ->
-        let x = !cntr in
-        incr cntr;
-        x
-    in
-    let rec string_of_lltype visited ty =
-      try 
-        let modname, name = List.assq ty !defined_names in
-        modname ^ "." ^ name, []
-      with Not_found ->
-        if List.memq ty visited then 
-          let name = "'" ^ string_of_int (create_name ()) in
-          name, [ty, name]
-        else 
-          let visited = ty :: visited in
-          let s, recs =  
-            match classify_type ty with
-            | TypeKind.Integer -> 
-                "i" ^ string_of_int (integer_bitwidth ty), []
-            | TypeKind.Pointer -> 
-                let s, recs = string_of_lltype visited (element_type ty) in
-                s ^ "*", recs
-            | TypeKind.Struct ->
-                let name_recs = List.map (string_of_lltype visited) (Array.to_list (struct_element_types ty)) in
-                let s = "{ " ^ String.concat ", " (List.map fst name_recs) ^ " }" in
-                let recs = List.concat (List.map snd name_recs) in
-                if is_packed ty
-                then "<" ^ s ^ ">", recs
-                else s, recs
-            | TypeKind.Array -> 
-                let s, recs = string_of_lltype visited (element_type ty) in
-                "[" ^ (string_of_int (array_length ty)) ^ " x " ^ s ^ "]", recs
-            | TypeKind.Vector -> 
-                let s, recs = string_of_lltype visited (element_type ty) in
-                "<" ^ (string_of_int (vector_size ty)) ^ " x " ^ s ^ ">", recs
-            | TypeKind.Opaque -> "opaque", []
-            | TypeKind.Function -> 
-                let name_recs = List.map (string_of_lltype visited) (Array.to_list (param_types ty)) in
-                let s = String.concat ", " (List.map fst name_recs) in
-                let recs = List.concat (List.map snd name_recs) in
-                let ret, recs_ret = string_of_lltype visited (return_type ty) in
-                ret ^ " (" ^ s ^ ")", recs_ret @ recs
-            | TypeKind.Label -> "label", []
-            | TypeKind.Ppc_fp128 -> "ppc_fp128", []
-            | TypeKind.Fp128 -> "fp128", []
-            | TypeKind.X86fp80 -> "x86_fp80", []
-            | TypeKind.Double -> "double", []
-            | TypeKind.Float -> "float", []
-            | TypeKind.Void -> "void", []
-            | TypeKind.Metadata -> "metadata", []
-          in
-          try 
-            let name = List.assq ty recs in
-            "u" ^ name ^ "." ^ s, recs
-          with
-          | Not_found -> s, recs
-    in
-    fst (string_of_lltype [] ty)
-
-  let string_of ty = string_of_lltype !<ty
-
-  (* now with context *)
-  let void : void typ = P.unsafe ^$ void_type context
-  let i1 : i1 typ = P.unsafe ^$ i1_type context
-  let i8 : i8 typ = P.unsafe ^$ i8_type context
-  let i16 : i16 typ = P.unsafe ^$ i16_type context
-  let i32 : i32 typ = P.unsafe ^$ i32_type context 
-  let i64 : i64 typ = P.unsafe ^$ i64_type context
-  let integer x = integer context x
-  let float = float context 
-  let double = double context
-  let struct_ x = struct_ context x
-(*
-  let check_pointer t = match classify t with
-    | TypeKind.Pointer _ -> Obj.magic t (* !! *)
-    | _ -> assert false
-*)
-
-  (* void pointer is special in LLVM. It is illegal! *)
-  let pointer_void = pointer i8
-
-  let opaque () = opaque_type context
-  let refine opaque ~by = refine_type opaque by
-  let recursive (f : 'a typ -> 'b typ) : 'b typ =
-    let op = opaque () in
-    let ty = f (P.unsafe op) in
-    refine op ~by:(!<ty);
-    ty
-end

File ltype.mli

-open Ltype_intf
-
-module CF : S0
-include S0
-
-(** Extend CF with context dependent functions *)
-module Make(A : sig val context : Llvm.llcontext end) : S
-  (* lots of equalities but we cannot live without them... *)
-  with type void = void
-  and type i1 = i1
-  and type i8 = i8
-  and type i16 = i16
-  and type i32 = i32
-  and type i64 = i64
-  and type 'a integer = 'a integer
-  and type double = double
-  and type dots = dots
-  and type 'a struct_ = 'a struct_
-  and type 'a pointer = 'a pointer
-  and type 'a vector = 'a vector
-  and type ('a, 'b) array_ = ('a, 'b) array_
-  and type void_pointer = void_pointer
-  and module WithString = CF.WithString
-        (* CR : if WithString can be removed CF can be gone *)

File ltype_intf.ml

-open Spotlib.Spot.Phantom
-
-module type S0 = sig
-  (** phantom *)
-  type 'a typ = ('a, Llvm.lltype) t
-  type 'a typs = ('a, Llvm.lltype) ts
-  
-  (** descriptors *)
-  
-  type void = unit
-  type i1 = [`int | `i1]
-  type i8 = [`int | `i8]
-  type i16 = [`int | `i16]
-  type i32 = [`int | `i32]
-  type i64 = [`int | `i64]
-  type 'a integer
-  (* type float *) (* use OCaml's float *)
-  type double = [`floating | `double]
-  type dots
-  type 'a struct_
-  type ('a, 'b) array_ = [`array of 'a * 'b | `container of 'a] (* use OCaml's array *)
-  type 'a pointer = [`pointer of 'a | `container of 'a]  
-    (* The definition is to permit recursive definition like:
-       type t = (i32 * t pointer) struct_
-    *)
-  type 'a vector = [`vector of 'a | `container of 'a]
-  (* void pointer is special in LLVM. It is illegal! *)
-  type void_pointer = i8 pointer
-
-  module WithString : sig
-    val tags : ('a, ('tag * Llvm.lltype)) ts -> 'tag list
-    val types : ('a, ('tag * Llvm.lltype)) ts -> 'a typs
-    val combine : 'tag list -> 'a typs -> ('a, ('tag * Llvm.lltype)) ts
-    val tag : 'tag -> 'a typ -> ('a, ('tag * Llvm.lltype)) t
-  end
-end
-
-module type S = sig
-  include S0
-  val void : void typ
-  val i1 : i1 typ
-  val i8 : i8 typ
-  val i16 : i16 typ
-  val i32 : i32 typ
-  val i64 : i64 typ
-  val integer : 'tag * int -> 'tag integer typ
-  val float : float typ
-  val double : double typ
-
-  val pointer_void : void_pointer typ
-
-  val function_ : 'ret typ -> 'args typs -> ('args -> 'ret) typ
-  val var_arg_function : 'ret typ -> 'args typs -> ('args -> dots -> 'ret) typ
-  val function_params : ('args -> 'ret) typ -> 'args typs
-  val function_return : ('args -> 'ret) typ -> 'ret typ
-    (* function_ is prefixed to avoid the name clash with Monad.return *)
-  val struct_ : 'args typs -> 'args struct_ typ
-(*
-  val check_struct : 'a typ -> unknown struct_ typ
-    (** may raise Assert_failure *)
-*)
-
-  val struct_elements : 'args struct_ typ -> 'args typs
-  val array_ : 'a typ -> 'tag * int -> ('a, 'tag) array_ typ
-  val pointer : 'a typ -> 'a pointer typ
-(*
-  val check_pointer : 'a typ -> 'a pointer typ
-    (** may raise Assert_failure *)
-*)
-
-  val element : [>`container of 'a] typ -> 'a typ
-
-  val define_name : modname: string -> string -> 'a typ -> unit
-  val string_of : 'a typ -> string
-  val classify : 'a typ -> Llvm.TypeKind.t
-
-  val recursive : ('a typ -> 'b typ) -> 'b typ
-    (** [recursive f] returns a recusive type defined by [f] *)
-
-  (* size_ofs require Lvalue.v, so defined in Lvalue. They are lated exposed in Lwrap.Type.
-     val size_i64_of : 'a typ -> i64 v
-     val size_of : 'a typ -> i32 v
-  *)
-end 

File lvalue.ml

-open Llvm
-open Spotlib.Spot
-module P = Spotlib.Spot.Phantom
-open P.Open
-
-open Ltype
-
-(* Context Free *)
-module CF = struct
-  (** phantom *)
-  type 'a v = ('a, llvalue) P.t
-  type 'a vs = ('a, llvalue) P.ts
-  
-  let unsafe_annotate v (_t : 'ty typ) : 'ty v = P.unsafe v
-  
-  let dump v = dump_value !<v
-  let type_of (v : 'typ v) = P.unsafe ^$ type_of !<v
-  let typs_of (ts : 'typs vs) : 'typs typs = 
-    P.unsafe_of_list (List.map Llvm.type_of (P.to_list ts))
-  let set_name name v = set_value_name name !<v
-  let name v = value_name !<v
-  
-  let function_params (f : ('args -> 'ret) pointer v) : 'args vs = 
-    P.unsafe_list (Array.to_list (params !<f))
-end
-
-include CF
-
-module Make(A : sig val context : llcontext end) = struct
-  include A
-  include CF
-
-  module Ltype = Ltype.Make(A)
-
-  module Const = struct
-    let int v : [`int] v = P.unsafe ^$ const_int (if Sys.word_size = 32 then !<Ltype.i32 else !<Ltype.i64) v
-    let nativeint n : [`int] v = 
-      P.unsafe ^$ const_of_int64 (if Sys.word_size = 32 then !<Ltype.i32 else !<Ltype.i64) (Int64.of_nativeint n) false
-    let i32 n : i32 v = P.unsafe ^$ const_of_int64 (!<Ltype.i32) (Int64.of_int32 n) false
-    let i32_of_int n : i32 v = P.unsafe ^$ const_of_int64 (!<Ltype.i32) (Int64.of_int n) false
-    let i32_0 = i32_of_int 0
-    let i32_1 = i32_of_int 1
-    let i64 n : i64 v = P.unsafe ^$ const_of_int64 (!<Ltype.i64) n false
-    let double f : double v = P.unsafe ^$ const_float (!<Ltype.double) f
-    let bool b : i1 v = P.unsafe ^$ const_int (!<Ltype.i1) (if b then 1 else 0)
-  
-    let bitcast v (ty : 'typ typ) : 'typ v = P.unsafe ^$ const_bitcast !<v !<ty
-    let intcast (v : [>`int] v) (ty : ([>`int] as 'typ) typ) : 'typ v = P.unsafe ^$ const_intcast !<v !<ty
-    let ptrtoint (v : 'a pointer v) (ty : ([>`int] as 'typ) typ) : 'typ v = P.unsafe ^$ const_ptrtoint !<v !<ty
-    let null (ty : 'typ typ) : 'typ v = P.unsafe ^$ const_null !<ty
-  
-    let unsafe_gep v ints = 
-      P.unsafe ^$ const_gep !<v (Array.of_list (List.map (fun x -> !<(i32_of_int x)) ints))
-
-    module Gep = struct
-      include Gep
-      let gen cont v = gen (fun lst ->
-        let lst = List.map (function
-          | `int n -> n
-          | `llvalue _ -> assert false (* it must be constants *)) lst
-        in
-        cont (unsafe_gep v lst))
-
-      let pos = pos_const
-        (** [Gep.pos] can be dynamic. 
-            Therefore it is forbidden and overridden by [pos_const] *)
-    end
-
-    let gep v = Gep.gen (fun x -> x) v
-
-    let offset_of ty indices =
-      (* CR jfuruse: only for 32 bit arch! *)
-      ptrtoint (unsafe_gep (null (Ltype.pointer ty)) indices) Ltype.i32
-  end
-  
-  (* CR: size of is defined here, where value is available *)
-  let size_i64_of ty : i64 v = P.unsafe ^$ Llvm.size_of !<ty
-  let size_of ty : i32 v = Const.intcast (size_i64_of ty) Ltype.i32
-
-  module Analysis = struct
-    let assert_valid_function (v : ('a -> 'b) pointer v) = Llvm_analysis.assert_valid_function !<v
-  end
-end
-

File lvalue.mli

-open Llvm
-open Ltype
-open Lvalue_intf
-
-include S0
-
-module Make(A : sig val context : llcontext end) : S

File lvalue_intf.ml

-open Ltype
-open Spotlib.Spot.Phantom
-
-module type S0 = sig
-  (** phantom *)
-  type 'a v = ('a, Llvm.llvalue) t
-  type 'a vs = ('a, Llvm.llvalue) ts
-
-  val unsafe_annotate : Llvm.llvalue -> 'ty typ -> 'ty v 
-    (** annotate a type, but unsafe *)
-
-  val dump : 'ty v -> unit
-  val type_of : 'ty v -> 'ty typ
-  val typs_of : 'tys vs -> 'tys typs
-  val set_name : string -> 'ty v -> unit
-  val name : 'ty v -> string
-  val function_params : ('args -> 'ret) pointer v -> 'args vs
-end
-
-module type S = sig
-  include S0
-
-  module Const : sig
-    val int : int -> [`int] v
-    val nativeint : nativeint -> [`int] v
-    val i32 : int32 -> i32 v
-    val i32_of_int : int -> i32 v
-    val i32_0 : i32 v
-    val i32_1 : i32 v
-    val i64 : Int64.t -> i64 v
-    val double : float -> double v
-    val bool : bool -> i1 v
-    val bitcast : 'a v -> 'ty typ -> 'ty v
-    val intcast : [>`int] v -> ([>`int] as 'a) typ -> 'a v
-    val ptrtoint : 'a pointer v -> ([>`int] as 'a) typ -> 'a v
-    val null : 'ty typ -> 'ty v
-      (* [null ty] returns a null value of type [ty]. 
-         Note that it can take non pointer type. 
-         It does NOT create a null pointer for [ty pointer]! *)
-    val unsafe_gep : 'a pointer v -> int list -> 'unsafe pointer v
-
-    (** Type-safe GEP tools. See gep.mli for details *)
-    module Gep : sig
-      type ('a, 'final, 'res) t
-
-      val pos : int -> ([> `container of 'a], 'final, 'res) t -> (('a, 'final, 'res) t -> 'b) -> 'b
-      (* val pos : Llvm.llvalue -> ([> `container of 'a], 'final, 'res) t -> (('a, 'final, 'res) t -> 'b) -> 'b *) (* constant gep should not have this *)
-      val mem0 : (('a0 * _) struct_, 'final, 'res) t -> (('a0, 'final, 'res) t -> 'b) -> 'b
-      val mem1 : ((_ * ('a1 * _)) struct_, 'final, 'res) t -> (('a1, 'final, 'res) t -> 'b) -> 'b
-      val mem2 : ((_ * (_ * ('a2 * _))) struct_, 'final, 'res) t -> (('a2, 'final, 'res) t -> 'b) -> 'b
-      val mem3 : ((_ * (_ * (_ * ('a3 * _)))) struct_, 'final, 'res) t -> (('a3, 'final, 'res) t -> 'b) -> 'b
-      val mem4 : ((_ * (_ * (_ * (_ * ('a4 * _))))) struct_, 'final, 'res) t -> (('a4, 'final, 'res) t -> 'b) -> 'b
-      val mem5 : ((_ * (_ * (_ * (_ * (_ * ('a5 * _)))))) struct_, 'final, 'res) t -> (('a5, 'final, 'res) t -> 'b) -> 'b
-      val mem6 : ((_ * (_ * (_ * (_ * (_ * (_ * ('a6 * _))))))) struct_, 'final, 'res) t -> (('a6, 'final, 'res) t -> 'b) -> 'b
-      val mem7 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a7 * _)))))))) struct_, 'final, 'res) t -> (('a7, 'final, 'res) t -> 'b) -> 'b
-      val mem8 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a8 * _))))))))) struct_, 'final, 'res) t -> (('a8, 'final, 'res) t -> 'b) -> 'b
-      val mem9 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a9 * _)))))))))) struct_, 'final, 'res) t -> (('a9, 'final, 'res) t -> 'b) -> 'b
-    end
-
-    val gep : 'a pointer v -> (('a pointer, 'final, 'final pointer v) Gep.t -> 'b) -> 'b
-
-    val offset_of : 'ty typ -> int list -> i32 v (* CR jfuruse: Only for 32bit arch! *)
-  end
-  
-  module Analysis : sig 
-    val assert_valid_function : ('a -> 'b) pointer v -> unit 
-  end
-
-  val size_i64_of : 'a typ -> i64 v 
-  val size_of : 'a typ -> i32 v 
-end 
-
-

File lwrap.ml

-open Spotlib.Spot
-
-module Create(A : sig end) = struct
-
-  module Engine = Llvm_executionengine
-
-  (* We require [initialize_native_target] to make the engine real JIT.
-     Otherwise it fails to create a JIT and fall back to an interpreter,
-     which fails to find external symbols
-  *)
-  let _ = Engine.initialize_native_target ()
-    
-  let context = Llvm.global_context ()
-
-  module Value = Lvalue.Make(struct let context = context end)
-  module Type = struct
-    include Ltype.Make(struct let context = context end)
-    (* Copy size_of functions in Type *)
-    let size_i64_of = Value.size_i64_of
-    let size_of = Value.size_of
-  end
-
-  module CreateModule(A : sig
-    val opt : bool
-    val name : string
-  end) = struct
-    module M = Lmodule.Make(struct
-      include A
-      let context = context
-    end)
-    include M
-    include Lbuilder.Make(M)
-  end
-end

File lwrap.mli

-module Create(A : sig end) : Lwrap_intf.S

File lwrap_intf.ml

-open Spotlib.Spot
-
-module type M = sig
-  include Lmodule_intf.S
-  include Lbuilder_intf.S
-end
-
-module type S = sig
-  val context : Llvm.llcontext
-
-  open Lvalue
-  module Value : Lvalue_intf.S
-
-  open Ltype
-  module Type : sig
-    include Ltype_intf.S
-	(* lots of equalities but we cannot live without them... *)
-      with type void = void
-      and type i1 = i1
-      and type i8 = i8
-      and type i16 = i16
-      and type i32 = i32
-      and type i64 = i64
-      and type 'a integer = 'a integer
-      and type double = double
-      and type dots = dots
-      and type 'a struct_ = 'a struct_
-      and type 'a pointer = 'a pointer
-      and type 'a vector = 'a vector
-      and type ('a, 'b) array_ = ('a, 'b) array_
-      and type void_pointer = void_pointer
-
-    (* Type related functions originally defined in Lvalue.ml *)	
-    val size_i64_of : 'a typ -> i64 v
-    val size_of : 'a typ -> i32 v
-  end
-
-  module CreateModule(A : sig
-    val opt : bool
-    val name : string
-  end) : M
-end
+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 : Llvm.llcontext 
+  val name : string
+  val opt : bool
+end) = struct
+  module Type = Type.Make(A)
+  module Value = Value.Make(A)
+  open Type
+  open Value
+
+  include A
+
+  let module_ = Llvm.create_module context name
+  
+  (* Create the JIT. *)
+  
+  let engine = E.ExecutionEngine.create module_
+  module ExecutionEngine = struct
+    let run_function (lv : ('a -> 'b) pointer v) args = 
+      E.ExecutionEngine.run_function !<lv args engine
+  end
+  
+  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
+  
+  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 dump module_ = Llvm.dump_module module_
+  
+  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
+module Make(A : sig 
+  val context : Llvm.llcontext 
+  val name : string 
+  val opt : bool
+end) : Module_intf.S

File module_intf.ml

+open Type
+open Value
+
+open Spotlib.Spot.Phantom
+
+open Llvm_executionengine (* for GenericValue *)