Source

TyLLVM / src / LLVM.ml

type link_type = [
  | `Private
  | `Linker_private
  | `Linker_private_weak
  | `Internal
  | `Available_externally
  | `Linkonce
  | `Weak
  | `Common
  | `Appending
  | `Extern_weak
  | `Linkonce_odr
  | `Weak_odr
  | `Linkonce_odr_auto_hide
  | `External
  | `Dllimport
  | `Dllexport
  ]

type address =
  | Addrspace of int
  | Unnamed_addr
  | None_addr

type thread_local =
  | Localdynamic
  | Initialexec
  | Localexec

type calling_convention =
  | CCC
  | FastCC
  | ColdCC
  | CC of int

type visibility =
  | Default
  | Hidden
  | Protected

type function_attribute =
  | Alignstack of int
  | Alwaysinline
  | Cold
  | Nonlazybind
  | Inlinehint
  | Naked
  | Nobuiltin
  | Noduplicate
  | Noimplicitefloat
  | Noinline
  | Noredzone
  | Noreturn
  | Nounwind
  | Optsize
  | Readnone
  | Readonly
  | Returns_twice
  | Sanitize_address
  | Sanitize_memory
  | Sanitize_thread
  | Ssp
  | Sspreq
  | Sspstrong
  | Uwtable

type parameter_attribute =
  | Zeroext
  | Signext
  | Inreg
  | Byval
  | Sret
  | Noalias
  | Nocapture
  | Nest
  | Returned

type 'a instr =
  | Ret of 'a LLVM_types.value

type ('a, 'b, 'c) context_module =
  | Global of
    (string * thread_local option *
    address * link_type option * bool *
    'a LLVM_types.either * string option * int option)
  | Declaration of
    ('a LLVM_types.t * string * 'b LLVM_types.t array *
    [`External | `Dllimport | `Extern_weak ] option)
  | Definition of
    (('a LLVM_types.t * string * 'b LLVM_types.t array) * 'c instr list)

let string_of_link_type = function
  | `Private                -> "private"
  | `Linker_private         -> "linker_private"
  | `Linker_private_weak    -> "linker_private_weak"
  | `Internal               -> "internal"
  | `Available_externally   -> "available_externally"
  | `Linkonce               -> "linkonce"
  | `Weak                   -> "weak"
  | `Common                 -> "common"
  | `Appending              -> "appending"
  | `Extern_weak            -> "extern_weak"
  | `Linkonce_odr           -> "linkonce_odr"
  | `Weak_odr               -> "weak_odr"
  | `Linkonce_odr_auto_hide -> "linkonce_odr_auto_hide"
  | `External               -> "external"
  | `Dllimport              -> "dllimport"
  | `Dllexport              -> "dllexport"

let string_of_instr = function
  | Ret a                   -> "\tret " ^ (LLVM_types.value_to_string a)

let string_of_address = function
  | Addrspace i             -> "addr(" ^ (string_of_int i) ^ ")"
  | Unnamed_addr            -> "unnamed_addr"
  | None_addr               -> ""

let string_of_thread_local = function
  | Localdynamic            -> "thread_local(localdynamic)"
  | Initialexec             -> "thread_local(initialexec)"
  | Localexec               -> "thread_local(localexec)"

let string_of_global
  (id, thread_local, address, link_type, constant, data_type, section, align) =
  let string_thread_local = match thread_local with
    | None                  -> ""
    | Some a                -> " " ^ (string_of_thread_local a)
  in let string_address = match string_of_address address with
    | ""                    -> ""
    | a                     -> " " ^ a
  in let string_link_type = match link_type with
    | None                  -> ""
    | Some a                -> " " ^ (string_of_link_type a)
  in let string_constant = match constant with
    | true                  -> " constant"
    | false                 -> ""
  in let string_data_type = match data_type with
    | LLVM_types.Value v -> " " ^ LLVM_types.value_to_string v
    | LLVM_types.Type t -> " " ^ LLVM_types.to_string t
  in let string_section = match section with
    | None                  -> ""
    | Some a                -> ", section \"" ^ a ^ "\""
  in let string_align = match align with
    | None                  -> ""
    | Some a                -> ", align " ^ (string_of_int a)
  in "@" ^ id ^ " =" ^ string_thread_local ^ string_address ^ string_link_type
  ^ string_constant ^ string_data_type ^ string_section ^ string_align

let string_of_declaration
  (type_return, id, type_arguments, link_type) =
  let rec aux acc arr n =
    if n <= 0 then acc
    else aux (acc ^ ", " ^ (LLVM_types.to_string arr.(n))) arr (n - 1)
  in let string_type_return = (LLVM_types.to_string type_return)
  in let string_type_arguments =
    aux (if Array.length type_arguments > 0
      then (LLVM_types.to_string type_arguments.(0))
      else "") type_arguments (Array.length type_arguments - 1)
  in let string_link_type = match link_type with
    | None                  -> ""
    | Some a                -> (string_of_link_type a) ^ " "
  in "declare " ^ string_link_type ^ string_type_return ^ " @" ^ id
  ^ "(" ^ string_type_arguments ^ ")"

let string_of_definition
  ((type_return, id, type_arguments), instr_list) =
  let rec aux acc arr n =
    if n <= 0 then acc
    else aux (acc ^ ", " ^ (LLVM_types.to_string arr.(n))) arr (n - 1)
  in let string_type_return = (LLVM_types.to_string type_return)
  in let string_type_arguments =
    aux (if Array.length type_arguments > 0
      then (LLVM_types.to_string type_arguments.(0))
      else "") type_arguments (Array.length type_arguments - 1)
  in let string_instr_list =
    List.fold_left (fun a x -> a ^ (string_of_instr x) ^ "\n") "" instr_list
  in "define " ^ string_type_return ^ " @" ^ id
  ^ "(" ^ string_type_arguments ^ ")" ^ " {\n" ^ string_instr_list ^ "}"

let print_global a = print_string (string_of_global a)

let new_global
  ?(thread_local=None)
  ?(address=None_addr)
  ?(link_type=None)
  ?(constant=false)
  ?(section=None)
  ?(alignment=None)
  id data_type =
  Global (id, thread_local, address, link_type,
    constant, data_type, section, alignment)

let print_declaration a = print_string (string_of_declaration a)

let new_declaration
  ?(link_type=None) type_return id type_arguments =
  Declaration (type_return, id, type_arguments,
    (link_type :> [ `External | `Dllimport | `Extern_weak] option))

let print_definition a = print_string (string_of_definition a)

let new_definition
  type_return id type_arguments instr_list =
  Definition ((type_return, id, type_arguments), instr_list)

let print_context_module e =
  let aux = function
    | Global a              -> print_global a
    | Declaration a         -> print_declaration a
    | Definition a          -> print_definition a
  in aux e; print_newline ()