Source

ocaml-llvm-phantom / lib / type_ctxt.ml

Full commit
(* llvm type algebra *)

open Llvm
(* open Type *)

open Spotlib.Spot
module P = Phantom
open P.Open

(* This should be shared by all the Make(A) *)
let defined_names : (lltype * (string * string)) list ref = ref []

(** Extend CF with context dependent functions *)
module Make(A : sig val context : Context.t end) = struct
  include A

  include Type

  let classify ty = classify_type !<ty
  let string_of ty = Extension.Llvm.string_of_lltype !defined_names !<ty

  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 ((_tag : 'itag), x) : 'itag integer typ = P.unsafe & integer_type context x
  let integer_bitwidth t = integer_bitwidth !<t

  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

(* not in 3.2
  let opaque () = opaque_type 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 (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