Commits

camlspotter committed 5784da1

phantom module name convention

  • Participants
  • Parent commits 596013a

Comments (0)

Files changed (4)

 open Spotlib.Spot
-open Spotlib.Spot.Phantom
+module P = Spotlib.Spot.Phantom
+open P.Open
 
 module Builder = struct
   include Monad.Make(struct
     
   let magicM (v : 'a v m) : 'b v m = perform
     v <-- v;
-    return (magic v)
+    return (P.magic v)
 
   let unsafeM v = perform
     v <-- v;
-    return (unsafe v)
+    return (P.unsafe v)
 
   let call 
       ?(name="called") (* CR jfuruse: called + f's name *)
       | Llvm.TypeKind.Void -> ""
       | _ -> name
     in
-    unsafeM (Llvm.build_call !<f (to_array args) name)
+    unsafeM (Llvm.build_call !<f (P.to_array args) name)
 
   let call_va_args
       ?(name="called")
       | Llvm.TypeKind.Void -> ""
       | _ -> name
     in
-    unsafeM (Llvm.build_call !<f (Array.of_list (to_list args 
+    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 = 
       : 'ty v m =
     unsafeM (Llvm.build_pointercast !<v !<ty name)
 
-  (* unsafe *)
+  (* P.unsafe *)
   let unsafe_gep 
       ?(name = "gepped")
       (v : 'a pointer v)
   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) (c1 fmt) args ~name:"res")
+      Monad.ignore (call_va_args (Module.External.printf) (P.c1 fmt) args ~name:"res")
   ;;
 
   let cast_name v lty =
     in
     pointercast ~name v lty
 
-  let memcpy ~dst ~src ~size = call ~name:"copied" Module.External.memcpy (c3 dst src size)
+  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 (c2 dst 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 (c1 size);
+      ptr <-- call ~name Module.External.malloc (P.c1 size);
       if zero then bzero ptr ~size else return ();
       return ptr
   ;;
 
   let free ptr = perform
     ptr <-- bitcast ptr pointer_void;
-    Monad.ignore (call Module.External.free (c1 ptr))
+    Monad.ignore (call Module.External.free (P.c1 ptr))
   ;;
 
   let unsafe_const_load ?name ptr indices = perform
 
     (* 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 = unsafe (Llvm.block_parent bb)
+    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)) ts) 
+  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.Base.WithString.types args) in
     (* name args *)
     List.iter2 (fun lv_param name ->
       Value.set_name name lv_param) 
-      (to_unknown_list (function_params lv_f))
+      (P.to_unknown_list (function_params lv_f))
       (Ltype.Base.WithString.tags args);
     let bb = Block.append ~name:"entry" lv_f in
     perform 
       \  Format.eprintf "Created function %s@." name;
       return lv_f
 
-  let return_void : void v m = (fun _builder -> magic Const.i32_0)
+  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 name = Printf.sprintf "lbuilder.exec%d" !cntr in
       Format.eprintf "Executing %s...@." name;
       let f : (unit -> void) pointer v =
-        let proto = function_ void c0 in
+        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
 open Spotlib.Spot
-open Spotlib.Spot.Phantom
+module P = Spotlib.Spot.Phantom
+open P.Open
 
 module E = Llvm_executionengine
 module T = Llvm_target
     if Llvm.define_type_name name !<t module_ then
       match Llvm.type_by_name module_ name with
       | Some t -> 
-          let t = (unsafe t : 'a typ) in
+          let t = (P.unsafe t : 'a typ) in
           Type.define_name ~modname:A.name n t;
           t
       | None -> assert false
   let dump module_ = Llvm.dump_module module_
   
   module Function = struct
-    let lookup n = Option.map ~f:unsafe (Llvm.lookup_function n module_)
-    let declare n ty = unsafe (Llvm.declare_function n !<ty module_)
+    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 =
-      unsafe (Llvm.declare_function cname !<(function_ l_ret l_args) module_)
+      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 =
-      unsafe (Llvm.declare_function cname !<(var_arg_function l_ret l_args) module_)
+      P.unsafe (Llvm.declare_function cname !<(var_arg_function l_ret l_args) module_)
   
-    let malloc = declare "malloc" (pointer_void) (c1 i32)
-    let free = declare "free" void (c1 (pointer_void))
-    let memcpy = declare "memcpy" (pointer_void) (c3 (pointer_void) (pointer_void) i32)
-    let printf = declare_var_arg "printf" i32 (c1 (pointer i8))
-    let bzero = declare "bzero" void (c2 (pointer_void) i32)
+    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
 
 open Llvm
 open Spotlib.Spot
-open Spotlib.Spot.Phantom
+
+module P = Spotlib.Spot.Phantom
+open P.Open
 
 module Base = struct
   (** phantom *)
-  type 'a typ = ('a, lltype) t 
-  type 'a typs = ('a, lltype) ts
+  type 'a typ = ('a, lltype) P.t 
+  type 'a typs = ('a, lltype) P.ts
   
   (** descriptors *)
   
   type void_pointer = i8 pointer
 
   module type Tagged = sig
-    val tags : ('a, ('tag * lltype)) ts -> 'tag list
-    val types : ('a, ('tag * lltype)) ts -> 'a typs
-    val combine : 'tag list -> 'a typs -> ('a, ('tag * lltype)) ts
-    val tag : 'tag -> 'a typ -> ('a, ('tag * lltype)) t
+    val tags : ('a, ('tag * lltype)) P.ts -> 'tag list
+    val types : ('a, ('tag * lltype)) P.ts -> 'a typs
+    val combine : 'tag list -> 'a typs -> ('a, ('tag * lltype)) P.ts
+    val tag : 'tag -> 'a typ -> ('a, ('tag * lltype)) P.t
   end
 
   module Tagged = struct
-    let tags ts = List.map fst (to_list ts)
-    let types (ts : ('a, 'tag * lltype) ts) : 'a typs = 
-      unsafe_of_list (List.map snd (to_list ts))
-    let combine (tags : 'tag list) (ts : 'a typs) : ('a, ('tag * lltype)) ts =
-      unsafe_of_list (List.combine tags (to_list ts))
-    let tag t (v : ('a, lltype) t) : ('a, ('tag * lltype)) t = unsafe (t, !<v)
+    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
   
   module WithString = Tagged
   (* shorter names *)
   let classify ty = classify_type !<ty
   
-  let integer c ((_tag : 'itag), x) : 'itag integer typ = unsafe ^$ integer_type c x
-  let float c : float typ = unsafe ^$ float_type c
-  let double c : double typ = unsafe ^$ double_type c
-  let function_ : 'ret typ -> 'args typs -> ('args -> 'ret) typ = fun ret args -> unsafe ^$ function_type !<ret (to_array args)
-  let var_arg_function : 'ret typ -> 'args typs -> ('args -> dots -> 'ret) typ = fun ret args -> unsafe ^$ var_arg_function_type !<ret (to_array args)
+  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 = unsafe_of_array (param_types !<t)
-  let function_return (ty : ('args -> 'ret) typ) : 'ret typ = unsafe ^$ return_type !<ty
+  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 = unsafe ^$ struct_type c (to_array args)
+  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 = unsafe_of_array (struct_element_types !<t)
-  let array_ (t : 't typ) ((_tag : 'itag), size) : ('t, 'itag) array_ typ = unsafe ^$ array_type !<t size
+  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 = unsafe ^$ pointer_type !<t
+  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 = unsafe ^$ element_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;
   let string_of ty = string_of_lltype !<ty
 
   (* now with context *)
-  let void : void typ = unsafe ^$ void_type context
-  let i1 : i1 typ = unsafe ^$ i1_type context
-  let i8 : i8 typ = unsafe ^$ i8_type context
-  let i16 : i16 typ = unsafe ^$ i16_type context
-  let i32 : i32 typ = unsafe ^$ i32_type context 
-  let i64 : i64 typ = unsafe ^$ i64_type 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 refine opaque ~by = refine_type opaque by
   let recursive (f : 'a typ -> 'b typ) : 'b typ =
     let op = opaque () in
-    let ty = f (unsafe op) in
+    let ty = f (P.unsafe op) in
     refine op ~by:(!<ty);
     ty
 end
 open Llvm
 open Spotlib.Spot
-open Spotlib.Spot.Phantom
+module P = Spotlib.Spot.Phantom
+open P.Open
 
 open Ltype.Base
 
 module Base = struct
   (** phantom *)
-  type 'a v = ('a, llvalue) t
-  type 'a vs = ('a, llvalue) ts
+  type 'a v = ('a, llvalue) P.t
+  type 'a vs = ('a, llvalue) P.ts
   
-  let unsafe_annotate v (_t : 'ty typ) : 'ty v = unsafe v
+  let unsafe_annotate v (_t : 'ty typ) : 'ty v = P.unsafe v
   
   let dump v = dump_value !<v
-  let type_of (v : 'typ v) = unsafe ^$ type_of !<v
+  let type_of (v : 'typ v) = P.unsafe ^$ type_of !<v
   let typs_of (ts : 'typs vs) : 'typs typs = 
-    unsafe_of_list (List.map Llvm.type_of (to_list ts))
+    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 = 
-    unsafe_list (Array.to_list (params !<f))
+    P.unsafe_list (Array.to_list (params !<f))
 end
 
 open Base
   module Ltype = Ltype.Make(A)
 
   module Const = struct
-    let int v : [`int] v = unsafe ^$ const_int (if Sys.word_size = 32 then !<Ltype.i32 else !<Ltype.i64) v
+    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 = 
-      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 = unsafe ^$ const_of_int64 (!<Ltype.i32) (Int64.of_int32 n) false
-    let i32_of_int n : i32 v = unsafe ^$ const_of_int64 (!<Ltype.i32) (Int64.of_int n) false
+      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 = unsafe ^$ const_of_int64 (!<Ltype.i64) n false
-    let double f : double v = unsafe ^$ const_float (!<Ltype.double) f
-    let bool b : i1 v = unsafe ^$ const_int (!<Ltype.i1) (if b then 1 else 0)
+    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 = unsafe ^$ const_bitcast !<v !<ty
-    let intcast (v : [>`int] v) (ty : ([>`int] as 'typ) typ) : 'typ v = unsafe ^$ const_intcast !<v !<ty
-    let ptrtoint (v : 'a pointer v) (ty : ([>`int] as 'typ) typ) : 'typ v = unsafe ^$ const_ptrtoint !<v !<ty
-    let null (ty : 'typ typ) : 'typ v = unsafe ^$ const_null !<ty
+    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 = 
-      unsafe ^$ const_gep !<v (Array.of_list (List.map (fun x -> !<(i32_of_int x)) ints))
+      P.unsafe ^$ const_gep !<v (Array.of_list (List.map (fun x -> !<(i32_of_int x)) ints))
 
     let offset_of ty indices =
       (* CR jfuruse: only for 32 bit arch! *)
   end
   
   (* CR: size of is defined here, where value is available *)
-  let size_i64_of ty : i64 v = unsafe ^$ Llvm.size_of !<ty
+  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