Commits

camlspotter committed 0e89828

fix

Comments (0)

Files changed (11)

 open Llvm
 
 module Make(A : sig val context : llcontext end) = struct
-  module Ltype = struct
+  module Type = struct
     include Ltype
     include Ltype.Make(A)
   end
-  module Lvalue = struct
+  module Value = struct
     include Lvalue
     include Lvalue.Make(A)
   end
 
 module Make(Module : Lmodule_intf.S) = struct
   include Lbase.Make(Module)
-  open Ltype
-  open Lvalue
+  open Type
+  open Value
 
   module Module = Module
   open Module
   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
+    name ^ "=" ^ Type.string_of lty
 
   (* CR: bitcast is wrapped again! *)
   let cast ?name v lty = 
 
 module Make(Module : Lmodule_intf.S) = struct
   include Lbase.Make(Module)
-  open Ltype
-  open Lvalue
+  open Type
+  open Value
 
   open Module
 
   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
+    name ^ "=" ^ Type.string_of lty
 
   (* CR: bitcast is wrapped again! *)
   let cast ?name v lty = 
 
   module Block = struct
     let position_at_end v = Llvm.position_at_end v builder
-    let insertion = Llvm.insertion_block builder
+    let insertion () = Llvm.insertion_block builder
 
     (* They are independent from the builder *) 	
     let append ?(name="block") (v : ('a -> 'b) pointer t) = Llvm.append_block context name !=<v  
 
   let if_then_else (f_lv_cond : unit -> bool v) (f_lv_then : unit -> 'a v) (f_lv_else : unit -> 'a v) : 'a v = 
     (* get the current bb *)
-    let start_bb = Block.insertion in
+    let start_bb = Block.insertion () in
     (* get the function being defined *)
     let the_function = Block.parent start_bb in
     let lv_cond = f_lv_cond () in (* created in [start_bb] *)
     (* Codegen of 'then' can change the current block, update then_bb for the
      * phi. We create a new name because one is used for the phi node, and the
      * other is used for the conditional branch. *)
-    let new_then_bb = Block.insertion in
+    let new_then_bb = Block.insertion () in
 
     let else_bb = Block.append ~name:"else" the_function in
     (* Emit 'else' value. *)
     (* Codegen of 'else' can change the current block, update else_bb for the
      * phi. We create a new name because one is used for the phi node, and the
      * other is used for the conditional branch. *)
-    let new_else_bb = Block.insertion in
+    let new_else_bb = Block.insertion () in
 
     (* Emit merge block. *)
     let merge_bb = Block.append ~name:"ifcont" the_function in
 
   module Block : sig
     val position_at_end : Llvm.llbasicblock -> unit
-    val insertion : Llvm.llbasicblock
+    val insertion : unit -> Llvm.llbasicblock
     val append : ?name:string -> ('a -> 'b) pointer v -> Llvm.llbasicblock
     val parent : Llvm.llbasicblock -> ('a -> 'b) pointer v
   end
   val opt : bool
 end) = struct
   include Lbase.Make(A)
-  open Ltype
-  open Lvalue
+  open Type
+  open Value
 
   include A
 
 
 open Llvm
 
+module type S0 = sig
+  (** 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 = [`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_ *) (* use OCaml's array *)
+  type 'a pointer
+  type 'a vector
+  (* void pointer is special in LLVM. It is illegal! *)
+  type void_pointer = i8 pointer
+end
+
 module Ltype = struct
   (** phantom *)
   include Phantom.Make(struct type t = lltype end)
 
 include Ltype
 
+module type S = 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
+end 
+
 module Make(A : sig val context : llcontext end) = struct
   include A
 
 open Llvm
 
-(** phantom *)
-include Phantom_intf.S with type elt = lltype
-type 'a typ = 'a t
-type 'a typs = 'a ts
+module type S0 = sig
+  (** 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 = [`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_ *) (* use OCaml's array *)
+  type 'a pointer
+  type 'a vector
+  (* void pointer is special in LLVM. It is illegal! *)
+  type void_pointer = i8 pointer
+end
 
-val ( !:< ) : 'a typ -> lltype
-val ( !:> ) : lltype -> unknown typ
-val ( !:? ) : 'a typ -> unknown typ
+include S0
 
-(** descriptors *)
-
-type void
-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_ *) (* 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
+module type S = sig
   val void : void typ
   val i1 : i1 typ
   val i8 : i8 typ
 
   val string_of : 'a typ -> string
   val classify : 'a typ -> TypeKind.t
+end 
 
-end
+module Make(A : sig val context : llcontext end) : S
 
 module type Tagged = sig
   type tag
   (* 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
+  let dump = dump_value
+  let type_of v = Obj.magic (type_of v) (* !! *)
+  let set_name = set_value_name
+  let name = value_name
 
   module Const = struct
     let int = const_int (if Sys.word_size = 32 then !:<Ltype.i32 else !:<Ltype.i64)
 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
+  val dump : 'ty v -> unit
+  val type_of : 'ty v -> 'ty typ
+  val set_name : string -> 'ty v -> unit
+  val name : 'ty v -> string
 
   module Const : sig
     val int : int -> unknown v
       let context = context
     end)
     include M
-    module CreateBuilder(A : sig end) = Lbuilder2.Make(M)
+    module CreateBuilder(A : sig end) = Lbuilder.Make(M)
   end
 end

lwrap.mli

-open Spotlib.Spot
-
-open Ltype
-open Lvalue
-
-module Create(A : sig  end) : sig
-  val context : Llvm.llcontext
-  
-  module CreateModule(A : sig 
-    val opt : bool 
-    val name : string 
-  end) : sig
-    
-    val name : string
-    val module_ : Llvm.llmodule
-    val define_type_name : string -> 'a typ -> bool
-    val dump : Llvm.llmodule -> unit
-    
-    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
-      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
-
-    module CreateBuilder(A : sig end) : sig
-      val builder : Llvm.llbuilder
-    
-      val call : ?name:string -> ('a -> 'b) pointer v -> 'a vs -> 'b v
-      val call_va_args : ?name: string -> ('a -> dots -> 'b) pointer v -> 'a vs -> unknown v list -> 'b v
-    
-      val global_stringptr : ?name:string -> string -> i8 pointer v
-    
-      val bitcast : ?name:string -> 'a v -> 'b typ -> 'b v
-    
-      val unsafe_gep : ?name:string -> 'a pointer v -> i32 v list -> 'unsafe pointer v
-        
-      val load : ?name:string -> 'a pointer v -> 'a v
-      val store : 'a v -> dst:'a pointer v -> unit
-        
-      val ret : 'a v -> unit
-        
-      val phi : ?name:string -> ('a v * Llvm.llbasicblock) list -> 'a v
-    
-      val cond_br : bool v -> Llvm.llbasicblock -> Llvm.llbasicblock -> unit
-    
-      val br : Llvm.llbasicblock -> unit
-    
-      val is_null : ?name:string -> 'a pointer v -> bool v
-    
-      val add : ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v
-      val sub : ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v
-      val mul : ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v
-      val sdiv : ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v
-      val fadd : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v
-      val fsub : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v
-      val fmul : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v
-      val fdiv : ?name:string -> ([>`floating] as 'a) v -> 'a v -> 'a v
-      val icmp : Llvm.Icmp.t -> ?name:string -> ([>`int] as 'a) v -> 'a v -> bool v
-      val fcmp : Llvm.Fcmp.t -> ?name:string -> ([>`floating] as 'a) v -> 'a v -> bool v
-    
-      val printf : string -> unknown v list -> unit
-    
-      val cast : ?name:string -> 'a v -> 'b typ -> 'b v
-      val pointercast : ?name:string -> 'a pointer v -> 'b typ -> 'b v
-    
-      val malloc : ?name:string -> cont:'a typ -> i32 v -> 'a pointer v
-      val malloc_lty : ?name:string -> cont:'a typ -> 'a pointer v
-      val memcpy : dst:void_pointer v -> src:void_pointer v -> size:i32 v -> void_pointer v
-      val bzero : void_pointer v -> size:i32 v -> unit
-      val free : void_pointer v -> unit
-      val unsafe_const_load : ?name:string -> 'a pointer v -> int list -> 'unsafe v
-      val unsafe_const_store : 'a pointer v -> int list -> 'unsafe v -> unit
-    
-      module Block : sig
-        val position_at_end : Llvm.llbasicblock -> unit
-        val insertion : Llvm.llbasicblock
-        val append : ?name:string -> ('a -> 'b) pointer v -> Llvm.llbasicblock
-        val parent : Llvm.llbasicblock -> ('a -> 'b) pointer v
-      end
-    
-      val func : string -> 'a typ -> 'b Ltype.WithString.ts -> ('b vs -> 'a v) -> ('b -> 'a) pointer v
-      val if_then_else : (unit -> bool v) -> (unit -> 'a v) -> (unit -> 'a v) -> 'a v
-    end
-  end
-end