Source

TyLLVM / src / LLVM.ml

Full commit
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 variable =
  | VGlobal of string
  | VLocal of string

type 'a instr =
  | Ret of 'a LLVM_types.value
  | Call of (bool * calling_convention option *
    [`Zeroext | `Signext | `Inreg ] option * 'a LLVM_types.t *
    variable * ('a instr list))

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_variable : variable -> string = function
  | VGlobal s               -> "@" ^ s
  | VLocal s                -> "%" ^ s

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_parameter_attribute = function
  | `Zeroext                -> "zeroext"
  | `Signext                -> "signext"
  | `Inreg                  -> "inreg"
  | `Byval                  -> "byval"
  | `Sret                   -> "sret"
  | `Noalias                -> "noalias"
  | `Nocapture              -> "nocapture"
  | `Nest                   -> "nest"
  | `Returned               -> "returned"

let string_of_calling_conventation = function
  | CCC                     -> "ccc"
  | FastCC                  -> "fastcc"
  | ColdCC                  -> "coldcc"
  | CC i                    -> "cc " ^ (string_of_int i)

let rec string_of_instr a =
  let rec aux acc = function
    | [] -> acc
    | x :: r -> aux (acc ^ ", " ^ (string_of_instr x)) r
  in match a with
    | Ret a                   -> "\tret " ^ (LLVM_types.value_to_string a)
    | Call (tail, cconv, ret_attr, ret_type, name, arguments) ->
        let tail_string = if tail = true then "tail " else "" in
        let cconv_string = match cconv with
          | Some a -> " " ^ (string_of_calling_conventation a)
          | None -> ""
        in let ret_attr_string = match ret_attr with
          | Some a -> " " ^ (string_of_parameter_attribute a)
          | None -> ""
        in let ret_type_string = " " ^ (LLVM_types.to_string ret_type)
        in let name_string = " " ^ (string_of_variable name)
        in let arguments_string = match arguments with
          | [] -> ""
          | x :: r -> aux (string_of_instr x) r
        in "\t" ^ tail_string ^ "call" ^ cconv_string ^ ret_attr_string ^
        ret_type_string ^ name_string ^ "(" ^ arguments_string ^ ")"

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 call
  ?(tail=false)
  ?(cconv=None)
  ?(ret_attr=None)
  ret_type name arguments =
  Call (tail, cconv, (ret_attr :> [ `Zeroext | `Signext | `Inreg ] option),
    ret_type, name, arguments)

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 ()