Commits

camlspotter committed 9156c98

added files

  • Participants

Comments (0)

Files changed (18)

+.*\.cm[a-z]+$
+.*~$
+\.(sp[io]t|annot|o|cm[a-z]+|orig|omc|lock)$
+\.omakedb$
+.*\.a
+name="llvm_phantom"
+version="0.0.1"
+description="LLVM OCaml binding with Phantom type"
+archive(byte)="llvm_phantom.cmo"
+archive(native)="llvm_phantom.cmx"
+linkopts = ""
+.PHONY: all install clean
+
+USE_OCAMLFIND = true
+
+OCAMLINCLUDES +=
+
+OCAMLFLAGS    += -annot -w Ae
+OCAMLCFLAGS   +=
+OCAMLOPTFLAGS +=
+OCAML_LINK_FLAGS +=
+OCAML_BYTE_LINK_FLAGS +=
+OCAML_NATIVE_LINK_FLAGS +=
+
+OCAMLFIND_PREINSTALLED_LIBRARIES += llvm
+
+OCAMLPACKS[]= 
+    llvm planck
+
+OCAMLDEPFLAGS= -syntax camlp4o -package monad
+OCAMLPPFLAGS= -syntax camlp4o -package monad
+
+FILES[] =
+   utils
+   phantom_intf
+   phantom
+   ltype
+   lvalue
+   lbase
+   lmodule_intf
+   lmodule
+   lbuilder
+
+OCAML_LIBS +=
+OCAML_CLIBS +=
+OCAML_OTHER_LIBS +=
+OCAML_LIB_FLAGS +=
+
+MyOCamlPackage(llvm_phantom, $(FILES), $(EMPTY), $(EMPTY))
+open Llvm
+
+module Make(A : sig val context : llcontext end) = struct
+  module Ltype = struct
+    include Ltype
+    include Ltype.Make(A)
+  end
+  module Lvalue = struct
+    include Lvalue
+    include Lvalue.Make(A)
+  end
+end
+open Utils
+
+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
+  include Lbase.Make(Module)
+  open Ltype
+  open Lvalue
+
+  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 magicM (v : 'a v m) : 'b v m = perform
+    v <-- v;
+    return (Lvalue.magic v)
+
+  let unsafeM v = perform
+    v <-- v;
+    return (Lvalue.unsafe v)
+
+  let call 
+      ?(name="called") (* CR jfuruse: called + f's name *)
+      (f : ('args -> 'ret) pointer v)
+      (args : 'args vs)
+      : 'ret v m = 
+    unsafeM (Llvm.build_call !=<f (Lvalue.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 = 
+    unsafeM (Llvm.build_call !=<f (Array.of_list (Lvalue.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)
+
+  (* 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 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)
+
+  let ret x : unit m = Monad.ignore (Llvm.build_ret !=<x)
+
+  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 : bool 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) : bool 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) : bool 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) (Lvalue.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 ^ "=" ^ Ltype.string_of lty
+
+  (* CR: bitcast is wrapped again! *)
+  let cast ?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 malloc : ?name:string -> 
+    cont:'ty typ ->
+    i32 v -> 
+    'ty pointer v m = 
+    fun ?(name="alloced") ~cont size -> perform
+      alloced <-- call ~name Module.External.malloc (Lvalue.c1 size);
+      cast alloced (pointer cont)
+  ;;
+
+  let malloc_lty ?name ~cont:(lty : 'ty typ) = malloc ?name ~cont:lty (size_of lty) 
+
+  let memcpy ~dst ~src ~size = call ~name:"copied" Module.External.memcpy (Lvalue.c3 dst src size)
+
+  let bzero dst ~size = Monad.ignore (call Module.External.bzero (Lvalue.c2 dst size))
+
+  let free ptr = Monad.ignore (call Module.External.free (Lvalue.c1 ptr))
+  ;;
+
+  let unsafe_const_load ?name ptr indices = perform
+    gepped <-- unsafe_gep ~name:"for_load" ptr (List.map Const.int32_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.int32_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 t) = Llvm.append_block context name !=<v  
+    let parent bb : ('a -> 'b) pointer t = Lvalue.unsafe (Llvm.block_parent bb)
+  end
+
+  module StringType = Ltype.Tagged(struct type tag = string end)
+  
+  let func name (lty_return : 'ret typ) (args : 'args StringType.ts) f : ('args -> 'ret) pointer v m =
+    Format.eprintf "Creating function %s@." name;
+    let lty = function_ lty_return (StringType.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) 
+      (Lvalue.to_unknown_list (function_params lv_f))
+      (StringType.tags args);
+    let bb = Block.append ~name:"entry" lv_f in
+    perform 
+      Block.position_at_end bb;
+      lv_body <-- f (function_params lv_f);
+      (* Finish off the function. *)
+      ret lv_body;
+      (* Validate the generated code, checking for consistency. *)
+      \ Value.dump lv_f;
+      \ Analysis.assert_valid_function lv_f;
+      (* Optimize the function *)
+      \ Module.PassManager.run_function_if_opt lv_f;
+      \  Format.eprintf "Created function %s@." name;
+      return lv_f
+
+
+  let if_then_else (f_lv_cond : bool v m) (f_lv_then : 'a v m) (f_lv_else : 'a v m) : 'a v m = perform
+    (* get the current bb *)
+    start_bb <-- Block.insertion;
+    (* get the function being defined *)
+    let the_function = Block.parent start_bb in
+    lv_cond <-- f_lv_cond; (* created in [start_bb] *)
+    (* before adding branching, we must create the destinations *)
+
+    let then_bb = Block.append ~name:"then" the_function in
+    (* Emit 'then' value. *)
+    Block.position_at_end then_bb;
+    lv_then <-- f_lv_then;
+    (* Codegen of 'then' can change the current block, update then_bb for the
+     * phi. We create a new name because one is used for the phi node, and the
+     * other is used for the conditional branch. *)
+    new_then_bb <-- Block.insertion;
+
+    let else_bb = Block.append ~name:"else" the_function in
+    (* Emit 'else' value. *)
+    Block.position_at_end else_bb;
+    lv_else <-- f_lv_else;
+    (* Codegen of 'else' can change the current block, update else_bb for the
+     * phi. We create a new name because one is used for the phi node, and the
+     * other is used for the conditional branch. *)
+    new_else_bb <-- Block.insertion;
+
+    (* Emit merge block. *)
+    let merge_bb = Block.append ~name:"ifcont" the_function in
+    Block.position_at_end merge_bb;
+    let incoming = [(lv_then, new_then_bb); (lv_else, new_else_bb)] in
+    (* Llvm.build_phi returns the merged value, which can be used the
+     return of the entire (if ...) *)
+    phi <-- phi incoming ~name:"iftmp";
+
+    (* Return to the start block to add the conditional branch. *)
+    Block.position_at_end start_bb;
+    Monad.ignore (cond_br lv_cond then_bb else_bb);
+
+    (* Set a unconditional branch at the end of the 'then' block and the
+     * 'else' block to the 'merge' block. *)
+    Block.position_at_end new_then_bb;
+    Monad.ignore (br merge_bb);
+
+    Block.position_at_end new_else_bb;
+    Monad.ignore (br merge_bb);
+
+    (* Finally, set the G.builder to the end of the merge block. *)
+    Block.position_at_end merge_bb;
+
+    return phi
+end
+open Utils
+open Ltype
+open Lvalue
+
+module Builder : Monad.T with type 'a t = Llvm.llbuilder -> 'a
+
+module Make(Module : Lmodule_intf.S) : sig
+  module Monad : sig
+    include Monad.T
+    val run : 'a t -> 'a
+  end
+  type 'a m = 'a Monad.t
+
+  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 bitcast : ?name:string -> 'a v -> 'b typ -> 'b v m
+
+  val unsafe_gep : ?name:string -> 'a pointer v -> i32 v list -> 'unsafe pointer v m
+    
+  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 phi : ?name:string -> ('a v * Llvm.llbasicblock) list -> 'a v m
+
+  val cond_br : bool v -> Llvm.llbasicblock -> Llvm.llbasicblock -> unit m
+
+  val br : Llvm.llbasicblock -> unit m
+
+  val is_null : ?name:string -> 'a pointer v -> bool v m
+
+  val add : ?name:string -> 'a v -> 'a v -> 'a v m
+  val sub : ?name:string -> 'a v -> 'a v -> 'a v m
+  val mul : ?name:string -> 'a v -> 'a v -> 'a v m
+  val sdiv : ?name:string -> 'a v -> 'a v -> 'a v m
+  val fadd : ?name:string -> 'a v -> 'a v -> 'a v m
+  val fsub : ?name:string -> 'a v -> 'a v -> 'a v m
+  val fmul : ?name:string -> 'a v -> 'a v -> 'a v m
+  val fdiv : ?name:string -> 'a v -> 'a v -> 'a v m
+  val icmp : Llvm.Icmp.t -> ?name:string -> 'a v -> 'a v -> bool v m
+  val fcmp : Llvm.Fcmp.t -> ?name:string -> 'a v -> 'a v -> bool v m
+
+  val printf : string -> unknown v list -> unit m
+
+  val cast : ?name:string -> 'a v -> 'b typ -> 'b v m
+  val pointercast : ?name:string -> 'a pointer v -> 'b typ -> 'b v m
+
+  val malloc : ?name:string -> cont:'a typ -> i32 v -> 'a pointer v m
+  val malloc_lty : ?name:string -> cont:'a typ -> 'a pointer v m
+  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 : void_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
+
+  module StringType : sig
+    (* OCaml 3.11 is annoying : No module type of *)
+    (* CR jfuruse: we should define a module type *)
+    include Phantom_intf.S with type elt = string * Llvm.lltype
+    val tags : 'a ts -> string list
+    val types : 'a ts -> 'a typs
+    val combine : string list -> 'a typs -> 'a ts
+    val tag : string -> 'a typ -> 'a t
+  end
+    
+  val func : string -> 'a typ -> 'b StringType.ts -> ('b vs -> 'a v m) -> ('b -> 'a) pointer v m
+  val if_then_else : bool v m -> 'a v m -> 'a v m -> 'a v m
+end
+open Utils
+
+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
+  include Lbase.Make(A)
+  open Ltype
+  open Lvalue
+
+  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 = Llvm.define_type_name n !:<t module_
+  
+  let dump module_ = Llvm.dump_module module_
+  
+  module Function = struct
+    let lookup n = Option.map ~f:Lvalue.unsafe (Llvm.lookup_function n module_)
+    let declare n ty = Lvalue.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) t =
+      Lvalue.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) t =
+      Lvalue.unsafe (Llvm.declare_function cname !:<(var_arg_function l_ret l_args) module_)
+  
+    let malloc = declare "malloc" (pointer_void) (Ltype.c1 i32)
+    let free = declare "free" void (Ltype.c1 (pointer_void))
+    let memcpy = declare "memcpy" (pointer_void) (Ltype.c3 (pointer_void) (pointer_void) i32)
+    let printf = declare_var_arg "printf" i32 (Ltype.c1 (pointer i8))
+    let bzero = declare "bzero" void (Ltype.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) : Lmodule_intf.S
+open Ltype
+open Lvalue
+
+open Llvm_executionengine (* for GenericValue *)
+
+module type S = sig
+  val context : Llvm.llcontext
+  val name : string
+  val opt : bool
+
+  val module_ : Llvm.llmodule
+  module ExecutionEngine : sig
+    (* CR: can be more type safe *)
+    val run_function : ('args -> 'ret) pointer v -> GenericValue.t array -> GenericValue.t
+  end
+  val define_type_name : string -> 'a typ -> bool
+  val dump : Llvm.llmodule -> unit
+  
+  module Function : sig
+    val lookup : string -> (unknown -> unknown) pointer t 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
+    val malloc : ((i32 -> void_pointer) pointer) v
+    val free : ((void_pointer -> void) pointer) v
+    val memcpy : (((void_pointer * void_pointer * i32) -> void_pointer) pointer) v
+    val printf : ((i8 pointer -> dots -> i32) pointer) v
+    val bzero : (((void_pointer * i32) -> void) pointer) v
+  end
+  module PassManager : sig 
+    val run_function_if_opt : ('a -> 'b) pointer v -> unit 
+  end
+end
+(* llvm type algebra *)
+
+open Llvm
+
+module Ltype = struct
+  (** phantom *)
+  include Phantom.Make(struct type t = lltype end)
+  type 'a typ = 'a t 
+  type 'a typs = 'a ts
+  
+  let (!:<) = (!<)
+  let (!:>) = (!>)
+  let (!:?) = (!?)
+  
+  (** descriptors *)
+  
+  type void
+  type i1 = bool
+  type i8 = char
+  type i16
+  type i32 = int32
+  type i64 = int64
+  type 'a integer
+  (* type float_d *)
+  type double
+  type dots
+  type 'a struct_
+  (* type ('a, 'tag) array *)
+  type 'a pointer
+  type 'a vector
+  
+  (* void pointer is special in LLVM. It is illegal! *)
+  type void_pointer = i8 pointer
+
+  let classify = classify_type
+  
+  let void = void_type
+  let i1 = i1_type
+  let i8 = i8_type
+  let i16 = i16_type
+  let i32 = i32_type
+  let i64 = i64_type
+  let integer c (_tag, x) = integer_type c x
+  let float = float_type
+  let double = double_type
+  let function_ ret args = function_type ret (to_array args)
+  let var_arg_function ret args = var_arg_function_type ret (to_array args)
+  let function_params t = of_array (param_types t)
+  let function_return = return_type
+  let struct_ c args = struct_type c (Array.of_list (to_list args))
+  let check_struct t = match classify t with
+    | TypeKind.Struct -> t
+    | _ -> assert false
+  
+  let struct_elements t = of_array (struct_element_types t)
+  let array t (_tag, size) = array_type t size
+    
+  let pointer = pointer_type
+  let element = element_type
+  let check_pointer t = match classify t with
+    | TypeKind.Pointer _ -> t
+    | _ -> assert false
+  
+  let string_of = string_of_lltype
+end
+
+include Ltype
+
+module Make(A : sig val context : llcontext end) = struct
+  include A
+
+  include Ltype
+
+  let void = void context
+  let i1 = i1 context
+  let i8 = i8 context
+  let i16 = i16 context
+  let i32 = i32 context 
+  let i64 = i64 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
+
+  module Tagged(M : sig type tag end) = struct
+    include Phantom.Make(struct 
+      type t = M.tag * lltype
+    end)
+
+    let tags ts = List.map fst (to_list ts)
+    let types (ts : 'a ts) : 'a Ltype.ts = 
+      Ltype.of_list (List.map (fun (_,ty) -> Ltype.unsafe ty) (to_list ts))
+    let combine tags (ts : 'a Ltype.ts) : 'a ts =
+      of_list (List.map unsafe (List.combine tags (Ltype.to_list ts)))
+    let tag t v = (t, v)
+  end
+end
+open Llvm
+
+(** phantom *)
+include Phantom_intf.S with type elt = lltype
+type 'a typ = 'a t
+type 'a typs = 'a ts
+
+val ( !:< ) : 'a typ -> lltype
+val ( !:> ) : lltype -> unknown typ
+val ( !:? ) : 'a typ -> unknown typ
+
+(** descriptors *)
+
+type void
+type i1 = bool
+type i8 = char
+type i16
+type i32 = int32
+type i64 = int64
+type 'a integer
+(* type float *) (* use OCaml's float *)
+type double
+type dots
+type 'a struct_
+(* type ('a, 'b) array_ *) (* use OCaml's array *)
+type 'a pointer
+type 'a vector
+(* void pointer is special in LLVM. It is illegal! *)
+type void_pointer = i8 pointer
+
+module Make(A : sig val context : llcontext end) : sig
+  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 : unknown typ -> unknown struct_ typ
+  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
+  val element : 'a pointer typ -> 'a typ
+
+  val string_of : 'a typ -> string
+  val classify : 'a typ -> TypeKind.t
+
+  module Tagged(M : sig type tag end) : sig
+    include Phantom_intf.S with type elt = M.tag * lltype
+    val tags : 'a ts -> M.tag list
+    val types : 'a ts -> 'a typs
+    val combine : M.tag list -> 'a typs -> 'a ts
+    val tag : M.tag -> 'a typ -> 'a t
+  end
+end
+open Llvm
+
+(** phantom *)
+include Phantom.Make(struct type t = llvalue end)
+type 'a v = 'a t
+type 'a vs = 'a ts
+
+let (!=<) = (!<)
+let (!=>) = (!>)
+let (!=?) = (!?)
+let wrap v _t = v
+
+module Make(A : sig val context : llcontext end) = struct
+  module Ltype = struct
+    include Ltype
+    include Ltype.Make(A)
+  end
+
+  (* We cannot easily open Ltype, since it overwrites Phantom *)
+  let (!:<) = Ltype.(!:<)
+
+  module Value = struct
+    let dump = dump_value
+    let type_of v = Obj.magic (type_of v) (* !! *)
+    let set_name = set_value_name
+    let name = value_name
+  end
+
+  module Const = struct
+    let int = const_int (if Sys.word_size = 32 then !:<Ltype.i32 else !:<Ltype.i64)
+    let nativeint n = 
+      const_of_int64 (if Sys.word_size = 32 then !:<Ltype.i32 else !:<Ltype.i64) (Int64.of_nativeint n) false
+    let int32 n = const_of_int64 (!:<Ltype.i32) (Int64.of_int32 n) false
+    let int32_of_int n = const_of_int64 (!:<Ltype.i32) (Int64.of_int n) false
+    let int64 n = const_of_int64 (!:<Ltype.i64) n false
+    let float = const_float (!:<Ltype.double)
+    let bool b = const_int (!:<Ltype.i1) (if b then 1 else 0)
+  
+    let bitcast v ty = const_bitcast v !:<ty
+    let intcast v ty = const_intcast v !:<ty
+    let ptrtoint v ty = const_ptrtoint v !:<ty
+    let null ty = const_null !:<ty
+  
+    let unsafe_gep v ints = 
+      const_gep v (Array.of_list (List.map int32_of_int ints))
+  end
+  
+  let function_params f = unsafe_list (Array.to_list (params f))
+
+  (* size of is defined here, where value is available *)
+  let size_i64_of ty : Ltype.i64 t = Llvm.size_of !:<ty
+  let size_of ty = Const.intcast (size_i64_of ty) Ltype.i32
+
+  let typs_of (ts : 'typs ts) : 'typs Ltype.typs =
+    Ltype.of_list
+      (List.map (fun llvalue -> Ltype.unsafe (Llvm.type_of llvalue))
+         (to_list ts))
+
+  module Analysis = struct
+    let assert_valid_function (v : ('a -> 'b) Ltype.pointer v) = Llvm_analysis.assert_valid_function !=<v
+  end
+end
+
+open Llvm
+open Ltype
+
+(** phantom *)
+include Phantom_intf.S with type elt = llvalue
+type 'a v = 'a t
+type 'a vs = 'a ts
+
+val ( !=< ) : 'a v -> llvalue
+val ( !=? ) : 'a v -> unknown v
+val ( !=> ) : llvalue -> unknown v
+val wrap : llvalue -> 'ty typ -> 'ty v 
+
+module Make(A : sig val context : llcontext end) : sig
+  module Value : sig
+    val dump : 'ty v -> unit
+    val type_of : 'ty v -> 'ty typ
+    val set_name : string -> 'ty v -> unit
+    val name : 'ty v -> string
+  end
+
+  module Const : sig
+    val int : int -> unknown v
+    val nativeint : nativeint -> unknown v
+    val int32 : int32 -> i32 v
+    val int32_of_int : int -> i32 v
+    val int64 : Int64.t -> i64 v
+    val float : float -> float v
+    val bool : bool -> i1 v
+    val bitcast : 'a v -> 'ty typ -> 'ty v
+    val intcast : 'a v -> 'ty typ -> 'ty v
+    val ptrtoint : 'a pointer v -> 'ty typ -> 'ty v
+    val null : 'ty typ -> 'ty pointer v
+    val unsafe_gep : 'a pointer v -> int list -> 'unsafe pointer v
+  end
+  
+  val function_params : ('args -> 'ret) pointer v -> 'args vs
+  val size_i64_of : 'a typ -> i64 v 
+  val size_of : 'a typ -> i32 v 
+
+  val typs_of : 'tys ts -> 'tys typs
+
+  module Analysis : sig 
+    val assert_valid_function : ('a -> 'b) pointer v -> unit 
+  end
+end
+
+module Make(M : sig type t end) = struct
+
+  type unknown = Phantom_intf.D.unknown
+  let unknown = Obj.magic 0 (* !! *)
+
+  type elt = M.t
+  type 'a t = elt
+  type 'a ts = elt list 
+
+  let of_list v = v
+  let of_array = Array.to_list
+  let to_list v = v
+  let to_unknown_list v = v
+  let to_array = Array.of_list
+  let to_unknown_array = Array.of_list
+  let length = List.length 
+
+  let (!<) x = x
+  let (!>) x = x
+  let (!?) x = x
+  let unsafe x = x
+  let unsafe_list x = x
+  let magic x = x
+
+  let c0 = []
+  let c1 t = [t]
+  let c2 t1 t2 = [t1; t2]
+  let c3 t1 t2 t3 = [t1; t2; t3]
+  let c4 t1 t2 t3 t4 = [t1; t2; t3; t4]
+  let c5 t1 t2 t3 t4 t5 = [t1; t2; t3; t4; t5]
+  let c6 t1 t2 t3 t4 t5 t6 = [t1; t2; t3; t4; t5; t6]
+  let c7 t1 t2 t3 t4 t5 t6 t7 = [t1; t2; t3; t4; t5; t6; t7]
+  let c8 t1 t2 t3 t4 t5 t6 t7 t8 = [t1; t2; t3; t4; t5; t6; t7; t8]
+  let c9 t1 t2 t3 t4 t5 t6 t7 t8 t9 = [t1; t2; t3; t4; t5; t6; t7; t8; t9]
+  let c10 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 = [t1; t2; t3; t4; t5; t6; t7; t8; t9; t10]
+  
+  let d1 = function [t] -> t | _ -> assert false
+  let d2 = function [t1; t2] -> (t1, t2) | _ -> assert false
+  let d3 = function [t1; t2; t3] -> (t1, t2, t3) | _ -> assert false
+  let d4 = function [t1; t2; t3; t4] -> (t1, t2, t3, t4) | _ -> assert false
+  let d5 = function [t1; t2; t3; t4; t5] -> (t1, t2, t3, t4, t5) | _ -> assert false
+  let d6 = function [t1; t2; t3; t4; t5; t6] -> (t1, t2, t3, t4, t5, t6) | _ -> assert false
+  let d7 = function [t1; t2; t3; t4; t5; t6; t7] -> (t1, t2, t3, t4, t5, t6, t7) | _ -> assert false
+  let d8 = function [t1; t2; t3; t4; t5; t6; t7; t8] -> (t1, t2, t3, t4, t5, t6, t7, t8) | _ -> assert false
+  let d9 = function [t1; t2; t3; t4; t5; t6; t7; t8; t9] -> (t1, t2, t3, t4, t5, t6, t7, t8, t9) | _ -> assert false
+  let d10 = function [t1; t2; t3; t4; t5; t6; t7; t8; t9; t10] -> (t1, t2, t3, t4, t5, t6, t7, t8, t9, t10) | _ -> assert false
+
+end
+module Make(M : sig type t end) : Phantom_intf.S with type elt = M.t and type 'a t = M.t
+module D = struct
+  type unknown
+end
+
+module type S = sig
+  type elt
+  type 'a t
+  type 'a ts
+
+  type unknown = D.unknown
+  val unknown : unknown
+
+  val of_list : 'a t list -> 'a ts
+  val of_array : 'a t array -> 'a ts
+  val to_list : 'a ts -> elt list
+  val to_unknown_list : 'a ts -> unknown t list
+  val to_array : 'a ts -> elt array
+  val to_unknown_array : 'a ts -> unknown t array
+  val length : 'a ts -> int
+
+  val (!<) : 'a t -> elt
+  val (!>) : elt -> unknown t
+  val (!?) : 'a t -> unknown t
+  val unsafe : elt -> 'a t
+  val unsafe_list : elt list -> 'a ts
+  val magic : 'a t -> 'b t
+
+  (* This encoding is correct only if the parameter cannot be the unit or a tuple *)
+  val c0 : unit ts
+  val c1 : 'a1 t -> 'a1 ts
+  val c2 : 'a1 t -> 'a2 t -> ('a1 * 'a2) ts
+  val c3 : 'a1 t -> 'a2 t -> 'a3 t -> ('a1 * 'a2 * 'a3) ts
+  val c4 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> ('a1 * 'a2 * 'a3 * 'a4) ts
+  val c5 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5) ts
+  val c6 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) ts
+  val c7 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) ts
+  val c8 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) ts
+  val c9 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t -> 'a9 t -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) ts
+  val c10 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t -> 'a9 t -> 'a10 t -> ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) ts
+  
+  val d1 : 'a1 ts -> 'a1 t
+  val d2 : ('a1 * 'a2) ts -> 'a1 t * 'a2 t
+  val d3 : ('a1 * 'a2 * 'a3) ts -> 'a1 t * 'a2 t * 'a3 t
+  val d4 : ('a1 * 'a2 * 'a3 * 'a4) ts -> 'a1 t * 'a2 t * 'a3 t * 'a4 t
+  val d5 : ('a1 * 'a2 * 'a3 * 'a4 * 'a5) ts -> 'a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t
+  val d6 : ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) ts -> 'a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t
+  val d7 : ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) ts -> 'a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t
+  val d8 : ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) ts -> 'a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t
+  val d9 : ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) ts -> 'a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
+  val d10 : ('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) ts -> 'a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t * 'a10 t
+end
+module Icmp = Llvm.Icmp
+module Fcmp = Llvm.Fcmp
+
+type t = 
+  | ICmp of Icmp.t
+  | FCmp of Fcmp.t
+  | IAdd
+  | ISub
+  | IMul
+  | IDiv
+  | FAdd
+  | FSub
+  | FMul
+  | FDiv
+      
+let to_string = function
+  | ICmp Icmp.Eq -> "Llvm__iEq"
+  | ICmp Icmp.Ne -> "Llvm__iNe"
+  | ICmp Icmp.Ugt -> "Llvm__iUgt"
+  | ICmp Icmp.Uge -> "Llvm__iUge"
+  | ICmp Icmp.Ult -> "Llvm__iUlt"
+  | ICmp Icmp.Ule -> "Llvm__iUle"
+  | ICmp Icmp.Sgt -> "Llvm__iSgt"
+  | ICmp Icmp.Sge -> "Llvm__iSge"
+  | ICmp Icmp.Slt -> "Llvm__iSlt"
+  | ICmp Icmp.Sle -> "Llvm__iSle"
+
+  | FCmp Fcmp.False -> "Llvm__fFalse"
+  | FCmp Fcmp.Oeq -> "Llvm__fOeq"
+  | FCmp Fcmp.Ogt -> "Llvm__fOgt"
+  | FCmp Fcmp.Oge -> "Llvm__fOge"
+  | FCmp Fcmp.Olt -> "Llvm__fOlt"
+  | FCmp Fcmp.Ole -> "Llvm__fOle"
+  | FCmp Fcmp.One -> "Llvm__fOne"
+  | FCmp Fcmp.Ord -> "Llvm__fOrd"
+  | FCmp Fcmp.Uno -> "Llvm__fUno"
+  | FCmp Fcmp.Ueq -> "Llvm__fUeq"
+  | FCmp Fcmp.Ugt -> "Llvm__fUgt"
+  | FCmp Fcmp.Uge -> "Llvm__fUge"
+  | FCmp Fcmp.Ult -> "Llvm__fUlt"
+  | FCmp Fcmp.Ule -> "Llvm__fUle"
+  | FCmp Fcmp.Une -> "Llvm__fUne"
+  | FCmp Fcmp.True -> "Llvm__fTrue"
+
+  | IAdd -> "Llvm__iadd"
+  | ISub -> "Llvm__isub"
+  | IMul -> "Llvm__imul"
+  | IDiv -> "Llvm__idiv"
+
+  | FAdd -> "Llvm__fadd"
+  | FSub -> "Llvm__fsub"
+  | FMul -> "Llvm__fmul"
+  | FDiv -> "Llvm__fdiv"
+;;
+
+let format ppf v = Format.pp_print_string ppf (to_string v)
+;;
+
+let all = 
+  [ ICmp Icmp.Eq
+  ; ICmp Icmp.Ne
+  ; ICmp Icmp.Ugt
+  ; ICmp Icmp.Uge
+  ; ICmp Icmp.Ult
+  ; ICmp Icmp.Ule
+  ; ICmp Icmp.Sgt
+  ; ICmp Icmp.Sge
+  ; ICmp Icmp.Slt
+  ; ICmp Icmp.Sle
+
+  ; FCmp Fcmp.False
+  ; FCmp Fcmp.Oeq
+  ; FCmp Fcmp.Ogt
+  ; FCmp Fcmp.Oge
+  ; FCmp Fcmp.Olt
+  ; FCmp Fcmp.Ole
+  ; FCmp Fcmp.One
+  ; FCmp Fcmp.Ord
+  ; FCmp Fcmp.Uno
+  ; FCmp Fcmp.Ueq
+  ; FCmp Fcmp.Ugt
+  ; FCmp Fcmp.Uge
+  ; FCmp Fcmp.Ult
+  ; FCmp Fcmp.Ule
+  ; FCmp Fcmp.Une
+  ; FCmp Fcmp.True
+
+  ; IAdd
+  ; ISub
+  ; IMul
+  ; IDiv
+
+  ; FAdd
+  ; FSub
+  ; FMul
+  ; FDiv
+  ]
+;;
+include Planck.Utils
+
+let memoize f =
+  let cache = Hashtbl.create 101 in
+  fun v -> try Hashtbl.find cache v with Not_found ->
+    let r = f v in
+    Hashtbl.replace cache v r;
+    r