Source

TyLLVM / 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 data_type =
  | Int of int
  | Array of int * data_type
  | Pointer of data_type
  | Pointer_function of data_type array * data_type

type address =
  | Addrspace of int
  | Unnamed_addr
  | None_addr

type thread_local =
  | Localdynamic
  | Initialexec
  | Localexec

type context_module =
  | Global of
    (string * thread_local option *
    address * link_type option * bool *
    data_type * string option * int option)
  | Declaration of
    (data_type * string * data_type array *
    [`External | `Dllimport | `Extern_weak ] option)


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 rec string_of_data_type ?f:(name = "") data =
  let rec aux acc arr = function
    | 0 -> acc
    | n -> aux (acc ^ ", " ^ (string_of_data_type arr.(n))) arr (n - 1)
  in match data with
  | Int i                   -> "i" ^ (string_of_int i)
  | Pointer t               -> string_of_data_type t ^ "*"
  | Array (i, t) ->
    "[" ^ (string_of_int i) ^ " x " ^ (string_of_data_type t) ^ "]"
  | Pointer_function (a, t) ->
    (string_of_data_type t) ^ " @" ^ name ^ "("
    ^ (aux (if Array.length a > 0 then (string_of_data_type a.(0)) else "") a
      (Array.length a - 1))
    ^ ") *"

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 = " " ^ (string_of_data_type data_type)
  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 = function
    | 0 -> acc
    | n -> aux (acc ^ ", " ^ (string_of_data_type arr.(n))) arr (n - 1)
  in let string_type_return = (string_of_data_type type_return)
  in let string_type_arguments =
    aux (if Array.length type_arguments > 0
      then (string_of_data_type 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_type_return ^ " @" ^ id
  ^ "(" ^ string_type_arguments ^ ")" ^ string_link_type

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_context_module e =
  let aux = function
    | Global a -> print_global a
    | Declaration a -> print_declaration a
  in aux e; print_newline ()