Commits

camlspotter committed 288b81e

fixing and adding functions

Comments (0)

Files changed (23)

 OCAMLPPFLAGS= -syntax camlp4o -package monad
 
 FILES[] =
+   extension
+   context
    type_intf
    type
    type_ctxt
 
   (** Casts *)
 
-  let bitcast 
-      ?(name="bitcast") 
-      (v : 'a v) 
-      (ty : 'ty typ)
-      : 'ty v m = 
-    unsafeM (Llvm.build_bitcast !<v !<ty name)
+  let cast_name ?name v lty = match name with
+    | Some n -> n
+    | None ->
+        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
 
-  let pointercast 
-      ?(name="pointer")
-      (v : 'a pointer v)
-      (ty : 'ty typ)
-      : 'ty v m =
-    unsafeM (Llvm.build_pointercast !<v !<ty name)
+  let bitcast ?name v lty = 
+    let name = cast_name ?name v lty in
+    unsafeM (Llvm.build_bitcast !<v !<lty name)
 
-  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
+  let pointercast ?name v lty = 
+    let name = cast_name ?name v lty in
+    unsafeM (Llvm.build_pointercast !<v !<lty name)
 
-  (* 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 intcast ?name v lty = 
+    let name = cast_name ?name v lty in
+    unsafeM (Llvm.build_intcast !<v !<lty name)
 
   (** Load/Store. Unsafe and type-safe versions *)
 
   let icmp c = cmp "icmped" (Llvm.build_icmp c)
   let fcmp c = cmp "fcmped" (Llvm.build_fcmp c)
 
+  (** Arithmetic type conversion *)
+
+  let sitofp ?(name="sitofped") i ty = 
+    unsafeM ^$ Llvm.build_sitofp !<i !<ty name
+
+  (** Memory *)
+
+  let alloca ?(name="inStack") ty =
+    unsafeM ^$ Llvm.build_alloca !<ty name
+
   (** Useful libc functions *)
 
   let printf : string -> unknown v list -> unit m = 
 
   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 intcast : ?name:string -> [>`int] v -> ([>`int] as 'a) typ -> '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
 
+
+  (** Arithmetic type conversion *)
+
+  val sitofp : ?name:string -> [>`int] v -> ([>`floating] as 'a) typ -> 'a v m
+
+
+  (** Memory *)
+
+  val alloca : ?name:string -> 'a typ -> 'a pointer v m
+
+
   (** Useful libc functions *)
 
   val printf : string -> unknown v list -> unit m
+open Llvm
+
+(** Contexts *)
+
+type t = llcontext
+
+let create = create_context 
+let dispose = dispose_context
+let global = global_context
+let mdkind_id = mdkind_id
+open Llvm
+
+(** {6 Contexts} *)
+
+type t = llcontext
+
+(** [create ()] creates a context for storing the "global" state in
+    LLVM. See the constructor [llvm::LLVMContext]. *)
+val create : unit -> t
+
+(** [destroy ()] destroys a context. See the destructor
+    [llvm::LLVMContext::~LLVMContext]. *)
+val dispose : t -> unit
+
+(** See the function [llvm::getGlobalContext]. *)
+val global : unit -> t
+
+(** [mdkind_id context name] returns the MDKind ID that corresponds to the
+    name [name] in the context [context].  See the function
+    [llvm::LLVMContext::getMDKindID]. *)
+val mdkind_id : t -> string -> int

examples/OMakefile

 
 MyOCamlProgram(double, double)
 MyOCamlProgram(double_phantom, double_phantom)
+MyOCamlProgram(sqrt, sqrt)
+MyOCamlProgram(pi, pi)
+(* Simple monte-carlo to compute pi *)
+
+open Llvm_phantom.Std
+module P = Phantom
+
+let context = Llvm.global_context () 
+
+include Create(struct let context = context end)
+open Type
+open Value
+
+include CreateModule(struct
+  let name = "mymodule"
+  let opt = true
+end)
+
+let random = External.declare "random" i32 P.c0
+let rand_max = 2147483647.0 (* This is RAND_MAX from stdlib.h, in my environment *)
+
+let random_point_1d = perform
+  r_i32 <-- call random P.c0;
+  r_double <-- sitofp r_i32 double;
+  fdiv r_double (Const.double rand_max) (* 0.0 - 1.0 *)
+
+let sq_dist_of_2d_point x y = perform
+  x2 <-- fmul x x;
+  y2 <-- fmul y y;
+  fadd x2 y2
+
+let incr v = perform
+  i <-- gep_load v (Gep.pos 0) Gep.end_;
+  i' <-- add i (Const.i32_1);
+  gep_store i' ~dst:v (Gep.pos 0) Gep.end_
+
+let number = 10000000
+
+let test = perform
+  in_points_ptr <-- alloca ~name:"in_points" i32;
+  gep_store (Const.i32_0) ~dst:in_points_ptr (Gep.pos 0) Gep.end_;
+  
+  for_loop (Const.i32_of_int number)
+    (fun n -> icmp Llvm.Icmp.Ne n Const.i32_0)
+    (fun n -> perform
+      x <-- random_point_1d;
+      y <-- random_point_1d;
+      dist <-- sq_dist_of_2d_point x y;
+      (* printf "%d %f %f %f\n" [!?n; !?x; !?y; !?dist]; *)
+      imp_if_then_else
+        (fcmp Llvm.Fcmp.Olt dist (Const.double 1.0))
+        (incr in_points_ptr)
+        (return ());
+      sub n Const.i32_1);
+
+  in_points <-- gep_load in_points_ptr (Gep.pos 0) Gep.end_;
+  in_points <-- sitofp in_points double;
+  fdiv in_points (Const.double (Pervasives.float number /. 4.0))
+
+let test_f = build (func0 "calc_pi" ~dump:true double () (fun _self () -> test))
+let run_test_f = ExecutionEngine.run_function0 test_f
+let run_test_ocaml () = Genvalue.as_float double (run_test_f ())
+
+let () = Printf.eprintf "sqrt(%d times)=%f\n" number (run_test_ocaml ())
+(* Declare sqrt in libm, and use it *)
+
+open Llvm_phantom.Std
+
+let context = Llvm.global_context () 
+
+include Create(struct let context = context end)
+open Type
+open Value
+
+include CreateModule(struct
+  let name = "mymodule"
+  let opt = true
+end)
+
+(* Declare "sqrt" with its type double(double) *)
+let sqrt = External.declare "sqrt" double (Phantom.c1 double)
+
+let run_sqrt = ExecutionEngine.run_function1 sqrt
+
+let run_sqrt_ocaml x = Genvalue.as_float double (run_sqrt (Genvalue.of_float double x))
+
+let () = Printf.eprintf "sqrt(3.0)=%f\n" (run_sqrt_ocaml 3.0)
+(* Some functions which could be additions or bug-fixes to the original LLVM OCaml binding *)
+
+module Llvm = struct
+  open Llvm
+
+  (** [string_of_lltype] of LLVM 2.8 has a bug: if it tries to print a recursive type, 
+      Kabooom! *)        
+  (* Here is a fix *)        
+  let string_of_lltype defined_names 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)
+end
+(* Some functions which could be additions or bug-fixes to the original LLVM OCaml binding *)
+open Llvm
+
+module Llvm : sig
+  val string_of_lltype : (Llvm.lltype * (string * string)) list -> lltype -> string
+  (** It can print named types and recursive types with mu notation *)
+end 
 module S = Llvm_scalar_opts
 
 module Make(A : sig 
-  val context : Llvm.llcontext 
+  val context : Context.t
   val name : string
   val opt : bool
 end) = struct
 
   include A
 
+  (* Initializtion *)
+
   let module_ = Llvm.create_module context name
-  
+
   (* Create the JIT. *)
-  
   let engine = E.ExecutionEngine.create module_
-  module ExecutionEngine = struct
-    let run_function (lv : ('args -> 'b) pointer v) (args : 'args Genvalue.vs) : 'b Genvalue.v = 
-      P.unsafe ^$ 
-        E.ExecutionEngine.run_function !<lv (P.List.to_array args) engine
-    let run_function0 lv () = run_function lv P.c0
-    let run_function1 lv a0 = run_function lv (P.c1 a0)
-    let run_function2 lv a0 a1 = run_function lv (P.c2 a0 a1)
-    let run_function3 lv a0 a1 a2 = run_function lv (P.c3 a0 a1 a2)
-    let run_function4 lv a0 a1 a2 a3 = run_function lv (P.c4 a0 a1 a2 a3)
-    let run_function5 lv a0 a1 a2 a3 a4 = run_function lv (P.c5 a0 a1 a2 a3 a4)
-    let run_function6 lv a0 a1 a2 a3 a4 a5 = run_function lv (P.c6 a0 a1 a2 a3 a4 a5)
-    let run_function7 lv a0 a1 a2 a3 a4 a5 a6 = run_function lv (P.c7 a0 a1 a2 a3 a4 a5 a6)
-    let run_function8 lv a0 a1 a2 a3 a4 a5 a6 a7 = run_function lv (P.c8 a0 a1 a2 a3 a4 a5 a6 a7)
-    let run_function9 lv a0 a1 a2 a3 a4 a5 a6 a7 a8 = run_function lv (P.c9 a0 a1 a2 a3 a4 a5 a6 a7 a8)
-    let run_function10 lv a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 = run_function lv (P.c10 a0 a1 a2 a3 a4 a5 a6 a7 a8 a9)
-  end
-  
+
   let fpm = Llvm.PassManager.create_function module_
     
   let _ =
       S.add_cfg_simplification fpm;
       ignore (Llvm.PassManager.initialize fpm)
     end
-  
+
+  (* module functions *)
+      
+  let dispose () = Llvm.dispose_module module_
+  let target_triple () = Llvm.target_triple module_
+  let set_target_triple s = Llvm.set_target_triple s module_
+  let data_layout () = Llvm.data_layout module_
+  let set_data_layout s = Llvm.set_data_layout s module_
+  (* let delete_type_name = delete_type_name *)
+  let set_inline_asm = Llvm.set_module_inline_asm module_
+
   let define_type_name n (t : 'a typ) = 
     let name = A.name ^ "." ^ n in
     if Llvm.define_type_name name !<t module_ then
           t
       | None -> assert false
     else failwithf "define_type_name %s failed" n
+
+  (* let delete_type_name : I do not think I need such a function. *)
+
+  let type_by_name : string -> unknown typ option = fun name ->
+    Option.map ~f:(!>) (Llvm.type_by_name module_ name)
+
+  let dump () = Llvm.dump_module module_
   
-  let dump module_ = Llvm.dump_module module_
+  module ExecutionEngine = struct
+    let run_function (lv : ('args -> 'b) pointer v) (args : 'args Genvalue.vs) : 'b Genvalue.v = 
+      P.unsafe ^$ 
+        E.ExecutionEngine.run_function !<lv (P.List.to_array args) engine
+    let run_function0 lv () = run_function lv P.c0
+    let run_function1 lv a0 = run_function lv (P.c1 a0)
+    let run_function2 lv a0 a1 = run_function lv (P.c2 a0 a1)
+    let run_function3 lv a0 a1 a2 = run_function lv (P.c3 a0 a1 a2)
+    let run_function4 lv a0 a1 a2 a3 = run_function lv (P.c4 a0 a1 a2 a3)
+    let run_function5 lv a0 a1 a2 a3 a4 = run_function lv (P.c5 a0 a1 a2 a3 a4)
+    let run_function6 lv a0 a1 a2 a3 a4 a5 = run_function lv (P.c6 a0 a1 a2 a3 a4 a5)
+    let run_function7 lv a0 a1 a2 a3 a4 a5 a6 = run_function lv (P.c7 a0 a1 a2 a3 a4 a5 a6)
+    let run_function8 lv a0 a1 a2 a3 a4 a5 a6 a7 = run_function lv (P.c8 a0 a1 a2 a3 a4 a5 a6 a7)
+    let run_function9 lv a0 a1 a2 a3 a4 a5 a6 a7 a8 = run_function lv (P.c9 a0 a1 a2 a3 a4 a5 a6 a7 a8)
+    let run_function10 lv a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 = run_function lv (P.c10 a0 a1 a2 a3 a4 a5 a6 a7 a8 a9)
+  end
   
   module Function = struct
     let lookup n = Option.map ~f:P.unsafe (Llvm.lookup_function n module_)
 module Make(A : sig 
-  val context : Llvm.llcontext 
+  val context : Context.t
   val name : string 
   val opt : bool
 end) : Module_intf.S
 open Llvm_executionengine (* for GenericValue *)
 
 module type S = sig
-  val context : Llvm.llcontext
+  val context : Context.t
   val name : string
   val opt : bool
 
   val module_ : Llvm.llmodule
+    (** Created module *)
 
+  (** Functions from Llvm.ml with shorter names *)
+
+  val dispose : unit -> unit
+    (** Calls Llvm.dispose_module. Use with care *)
+  val target_triple : unit -> string
+  val set_target_triple : string -> unit
+  val data_layout : unit -> string
+  val set_data_layout : string -> unit
   val define_type_name : string -> 'a typ -> 'a typ
-  val dump : Llvm.llmodule -> unit
+  (* delete_type_name : really you need it ? *)
+  val type_by_name : string -> unknown typ option
+  val dump : unit -> unit
+    (** Calls dump_module *)
+  val set_inline_asm : string -> unit
+    (** Calls set_module_inline_asm *)
 
   module ExecutionEngine : sig
     val run_function : ('args -> 'ret) pointer v -> 'args Genvalue.vs -> 'ret Genvalue.v
 module Gep = Gep
 module Genvalue = Genvalue
 module Create = Wrap.Create
+
+module Wrap_intf = Wrap_intf
 type i32 = [`int | `i32]
 type i64 = [`int | `i64]
 type 'a integer
-(* type float_d *)
+type float_ = [`floating | `float]
 type double = [`floating | `double]
+type x86fp80 = [`floating | `x86fp80]
+type fp128 = [`floating | `fp128]
+type ppc_fp128 = [`floating | `ppc_fp128]
 type dots
-type 'a struct_
-type ('a, 'tag) array_ = [`array of 'a * 'tag | `container of 'a]
+type 'a struct_ = [`members of 'a | `aligned_struct]
+type 'a packed_struct = [`members of 'a | `packed_struct]
+ type ('a, 'sizetag) array_ = [`array of 'a * 'sizetag | `container of 'a]
 type 'a pointer = [`pointer of 'a | `container of 'a]
-type 'a vector = [`vector of 'a | `container of 'a]
+type ('a, 'sizetag) vector = [`vector of 'a * 'sizetag | `container of 'a]
+type label
 
 (* void pointer is special in LLVM. It is illegal! *)
 type void_pointer = i8 pointer
+
+type address_space = int
 let defined_names : (lltype * (string * string)) list ref = ref []
 
 (** Extend CF with context dependent functions *)
-module Make(A : sig val context : llcontext end) = struct
+module Make(A : sig val context : Context.t end) = struct
   include A
 
   include Type
 
-  (* 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 : 'ret typ) (args : 'args typs) : ('args -> 'ret) typ =
-    P.unsafe ^$ function_type !<ret (P.List.to_array args)
-  let var_arg_function (ret : 'ret typ) (args : 'args typs) : ('args -> dots -> 'ret) typ = 
-    P.unsafe ^$ var_arg_function_type !<ret (P.List.to_array args)
+  let string_of ty = Extension.Llvm.string_of_lltype !defined_names !<ty
 
-  (* CR jfuruse: not for dots !*)
-  let function_params (t : ('args -> 'ret) typ) : 'args typs = 
-    P.List.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.List.to_array args)
-  
-  let struct_elements (t : 'typs struct_ typ) : 'typs typs = 
-    P.List.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 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, 
-      Kabooom! *)        
-  (* 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 integer ((_tag : 'itag), x) : 'itag integer typ = P.unsafe ^$ integer_type context x
+  let integer_bitwidth t = integer_bitwidth !<t
 
-  (* void pointer is special in LLVM. It is illegal! *)
-  let pointer_void = pointer i8
+  let float : float_ typ = P.unsafe ^$ float_type context 
+  let double : double typ = P.unsafe ^$ double_type context
+  let x86fp80 : x86fp80 typ = P.unsafe ^$ x86fp80_type context
+  let fp128 : fp128 typ = P.unsafe ^$ fp128_type context 
+  let ppc_fp128 : ppc_fp128 typ = P.unsafe ^$ ppc_fp128_type context
+
+  let function_ (ret : 'ret typ) (args : 'args typs) : ('args -> 'ret) typ =
+    P.unsafe ^$ function_type !<ret (P.List.to_array args)
+  let var_arg_function (ret : 'ret typ) (args : 'args typs) : ('args -> dots -> 'ret) typ = 
+    P.unsafe ^$ var_arg_function_type !<ret (P.List.to_array args)
+  (* CR jfuruse: not for dots !*)
+  let function_params (t : ('args -> 'ret) typ) : 'args typs = 
+    P.List.unsafe_of_array (param_types !<t)
+  let function_return (ty : ('args -> 'ret) typ) : 'ret typ = 
+    P.unsafe ^$ return_type !<ty
+
+  let struct_ (args : 'args typs) : 'args struct_ typ = 
+    P.unsafe ^$ struct_type context (P.List.to_array args)
+  let packed_struct (args : 'args typs) : 'args packed_struct typ =
+    P.unsafe ^$ packed_struct_type context (P.List.to_array args)
+  let struct_elements (t : [>`members of 'typs] typ) : 'typs typs = 
+    P.List.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 qualified_pointer (t : 't typ) aspace : 't pointer typ = P.unsafe ^$ qualified_pointer_type !<t aspace
+  let vector (t : 't typ) ((_tag : 'itag), size) : ('t, 'itag) vector typ =
+    P.unsafe ^$ vector_type !<t size
+  let element (t : [>`container of 't] typ) : 't typ = P.unsafe ^$ element_type !<t
+  let array_length (t : ('a, 'tag) array_ typ) = array_length !<t
+  let address_space (t : 'a pointer typ) = address_space !<t
+  let vector_size (t : ('a, 'tag) vector typ) = vector_size !<t
 
   let opaque () = opaque_type context
   let refine opaque ~by = refine_type opaque by
     let ty = f (P.unsafe op) in
     refine op ~by:(!<ty);
     ty
+  let void : void typ = P.unsafe ^$ void_type context
+  let label : label typ = P.unsafe ^$ label_type context
+
+  (* void pointer is special in LLVM. It is illegal! *)
+  let pointer_void = pointer i8
+
+  let define_name ~modname n t =
+    Format.eprintf "Registered named type %s.%s@." modname n;
+    defined_names := (!<t, (modname, n)) :: !defined_names
+
 end
 open Type
 
 (** Extend CF with context dependent functions *)
-module Make(A : sig val context : Llvm.llcontext end) : S
+module Make(A : sig val context : Context.t end) : S
   (* lots of equalities but we cannot live without them... *)
   with type void = void
   and type i1 = i1
   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) vector = ('a, 'b) vector
   and type ('a, 'b) array_ = ('a, 'b) array_
   and type void_pointer = void_pointer
   type i32 = [`int | `i32]
   type i64 = [`int | `i64]
   type 'a integer
-  (* type float *) (* use OCaml's float *)
+  type float_ = [`floating | `float]
   type double = [`floating | `double]
+  type x86fp80 = [`floating | `x86fp80]
+  type fp128 = [`floating | `fp128]
+  type ppc_fp128 = [`floating | `ppc_fp128]
   type dots
-  type 'a struct_
-  type ('a, 'b) array_ = [`array of 'a * 'b | `container of 'a] (* use OCaml's array *)
+  type 'a struct_ = [`members of 'a | `aligned_struct]
+  type 'a packed_struct = [`members of 'a | `packed_struct]
+  type ('a, 'sizetag) array_ = [`array of 'a * 'sizetag | `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]
+  type ('a, 'sizetag) vector = [`vector of 'a * 'sizetag | `container of 'a]
+  type label
+
   (* void pointer is special in LLVM. It is illegal! *)
   type void_pointer = i8 pointer
+
+  type address_space = int
 end
 
 module type S = sig
   include S0
-  val void : void typ
+
+  val context : Context.t
+
+  (** {6 Types} *)
+
+  val classify : 'a typ -> Llvm.TypeKind.t
+  (* val type_context *)
+  val string_of : 'a typ -> string
+    (** bugfixed version of string_of_lltype, which can print recursive types :-) *)
+
+  (** {7 Operations on integer types} *)
+
   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 integer_bitwidth : 'tag integer typ -> int
+
+  (** {7 Operations on real types} *)
+
+  val float : float_ typ
   val double : double typ
+  val x86fp80 : x86fp80 typ
+  val fp128 : fp128 typ
+  val ppc_fp128 : ppc_fp128 typ
 
-  val pointer_void : void_pointer typ
+  (** {7 Operations on function types} *)
 
   val function_ : 'ret typ -> 'args typs -> ('args -> 'ret) typ
   val var_arg_function : 'ret typ -> 'args typs -> ('args -> dots -> 'ret) typ
+  (* is_var_arg : we do not need it (prbbly). *)
+  val function_return : ('args -> 'ret) typ -> 'ret typ
+    (** return_type *)
   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 *)
+    (** param_types : function_ is prefixed to avoid the name clash with Monad.return *)
+
+  (** {7 Operations on struct types} *)
+
   val struct_ : 'args typs -> 'args struct_ typ
-(*
-  val check_struct : 'a typ -> unknown struct_ typ
-    (** may raise Assert_failure *)
-*)
+  val packed_struct : 'args typs -> 'args packed_struct typ
+  val struct_elements : [>`members of 'args] typ -> 'args typs
+  (* is_packed : we do not need it (probably) *)
 
-  val struct_elements : 'args struct_ typ -> 'args typs
+  (** {7 Operations on pointer, vector, and array types} *)
+
   val array_ : 'a typ -> 'tag * int -> ('a, 'tag) array_ typ
+    (** Unique tag type must be given for each integer. It is programmer's responsibility. 
+        I need a dependent type here... :-( *)
   val pointer : 'a typ -> 'a pointer typ
-(*
-  val check_pointer : 'a typ -> 'a pointer typ
-    (** may raise Assert_failure *)
-*)
+  val qualified_pointer : 'a typ -> address_space -> 'a pointer typ
+  val vector : 'a typ -> ('tag * int) -> ('a, 'tag) vector typ
+    (** Same remark as [array_] *)
+  val element : [>`container of 'a] typ -> 'a typ
+  val array_length : ('a, 'tag) array_ typ -> int
+    (** 'tag should have the unique type for the size and therefore must correspond with the result,
+        but we have no way to express this property in OCaml... :-( *)
+  val address_space : 'a pointer typ -> address_space
+  val vector_size : ('a, 'tag) vector typ -> int
+    (** Same remark as [array_length] *)
 
-  val element : [>`container of 'a] typ -> 'a typ
+  (** {7 Operations on other types} *)
+
+  val recursive : ('a typ -> 'b typ) -> 'b typ
+    (** [recursive f] returns a recusive type defined by [f]. *)
+  (* val opaque_type : use [recursive]. *)
+  val void : void typ
+  val label : label typ
+
+  (** {7 Operations on type handles} *)
+
+  (* external handle_to_type : lltype -> lltypehandle = "llvm_handle_to_type"
+     external type_of_handle : lltypehandle -> lltype = "llvm_type_of_handle"
+     external refine_type : lltype -> lltype -> unit = "llvm_refine_type"
+
+     I do not see we need to use it, for now.
+  *)
+
+  (** {7 and Some more...} *)
+      
+  val pointer_void : void_pointer 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 Value.v, so defined in Value. They are lated exposed in Wrap.Type.
      val size_i64_of : 'a typ -> i64 v
 module P = Phantom
 open P.Open
 
-module Make(A : sig val context : llcontext end) = struct
+module Make(A : sig val context : Context.t end) = struct
   include A
   include Value
 
-module Make(A : sig val context : Llvm.llcontext end) : Value_intf.S
+module Make(A : sig val context : Context.t end) : Value_intf.S
 
 
 let _ = Llvm_executionengine.initialize_native_target ()
 
 module Create(A : sig 
-  val context : Llvm.llcontext
+  val context : Context.t
 end) = struct
 
   include A
 module Create(A : sig 
-  val context : Llvm.llcontext
+  val context : Context.t
 end) : Wrap_intf.S
 end
 
 module type S = sig
-  val context : Llvm.llcontext
+  val context : Context.t
 
   open Value
   module Value : Value_intf.S
       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) vector = ('a, 'b) vector
       and type ('a, 'b) array_ = ('a, 'b) array_
       and type void_pointer = void_pointer