Commits

camlspotter committed 715253c

fixed

Comments (0)

Files changed (5)

     fun (v : unit m) ->
       incr cntr;
       let name = Printf.sprintf "lbuilder.exec%d" !cntr in
-      Format.eprintf "Executing %s...!?!?!?@." name;
+      Format.eprintf "Executing %s...@." name;
       let f : (unit -> void) pointer v =
         let proto = function_ void Type.c0 in
         match Module.Function.lookup name with
   let define_type_name n (t : 'a typ) = 
     if Llvm.define_type_name n !:<t module_ then
       match Llvm.type_by_name module_ n with
-      | Some t -> (Type.unsafe t : 'a typ)
+      | Some t -> 
+          let t = (Type.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
   
 
 open Base
 
+(* This should be shared by all the Make(A) *)
+let defined_names : (lltype * (string * string)) list ref = ref []
 
 module Make(A : sig val context : llcontext end) = struct
   include A
   let check_pointer t = match classify t with
     | TypeKind.Pointer _ -> t
     | _ -> assert false
-  
+
+  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 = string_of_lltype
 
   (* now with context *)
   val check_pointer : 'a typ -> 'a pointer typ
   val element : 'a pointer 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
 
       const_gep v (Array.of_list (List.map i32_of_int ints))
   end
   
-  (* size of is defined here, where value is available *)
+  (* CR: 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