Source

ocaml-llvm-phantom / lib / extension.ml

Full commit
(* 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
(* gone in 3.2
            | 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", []
            | Half -> assert false (* New in 3.2 *)
          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