1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
[@@@ocaml.text "/*"]
(** Copyright 2023-2024, Kakadu and contributors *)
(** SPDX-License-Identifier: LGPL-3.0-or-later *)
[@@@ocaml.text "/*"]
open Llvm
module type S = sig
val context : Llvm.llcontext
val module_ : Llvm.llmodule
val builder : Llvm.llbuilder
val build_store : Llvm.llvalue -> Llvm.llvalue -> Llvm.llvalue
val build_call : ?name:string -> lltype -> llvalue -> llvalue list -> llvalue
val define_func : string -> Llvm.lltype -> Llvm.lltype array -> Llvm.llvalue
val declare_func : string -> Llvm.lltype -> Llvm.lltype array -> Llvm.llvalue
val build_add : ?name:string -> llvalue -> llvalue -> llvalue
val build_sub : ?name:string -> llvalue -> llvalue -> llvalue
val build_mul : ?name:string -> llvalue -> llvalue -> llvalue
val build_sdiv : ?name:string -> llvalue -> llvalue -> llvalue
val build_icmp : ?name:string -> Icmp.t -> llvalue -> llvalue -> llvalue
val build_ret : llvalue -> llvalue
val build_br : llbasicblock -> llvalue
val build_cond_br : llvalue -> llbasicblock -> llbasicblock -> llvalue
val build_phi : ?name:string -> (llvalue * llbasicblock) list -> llvalue
val build_array_alloca : ?name:string -> lltype -> llvalue -> llvalue
val build_gep : ?name:string -> llvalue -> llvalue array -> llvalue
(** [set_metadata v kind fmt] sets metadata to value [v] of kind [k].
Returns this value [v]. Useful for attaching debugging *)
val set_metadata
: llvalue
-> string
-> ('a, Format.formatter, unit, llvalue) format4
-> 'a
(* ?? *)
val build_pointercast : ?name:string -> llvalue -> lltype -> llvalue
val position_at_end : llbasicblock -> unit
val append_block : ?name:string -> llvalue -> llbasicblock
val insertion_block : unit -> llbasicblock
(** Just aliases *)
val void_type : Llvm.lltype
val block_parent : Llvm.llbasicblock -> Llvm.llvalue
val entry_block : Llvm.llvalue -> Llvm.llbasicblock
val i64_type : Llvm.lltype
val i1_type : Llvm.lltype
val ptr_type : Llvm.lltype
val function_type : lltype -> lltype array -> lltype
val const_int : Llvm.lltype -> int -> Llvm.llvalue
val params : Llvm.llvalue -> Llvm.llvalue array
val pp_value : Format.formatter -> llvalue -> unit
end
let make context builder module_ =
let module L : S = struct
let context = context
let builder = builder
let module_ = module_
let build_store a b = Llvm.build_store a b builder
let build_call ?(name = "") typ f args =
build_call typ f (Array.of_list args) name builder
;;
let declare_func name ret params =
let typ = Llvm.function_type ret params in
Llvm.declare_function name typ module_
;;
let define_func name ret params =
let typ = Llvm.function_type ret params in
Llvm.define_function name typ module_
;;
let build_add ?(name = "") l r = build_add l r name builder
let build_sub ?(name = "") l r = build_sub l r name builder
let build_mul ?(name = "") l r = build_mul l r name builder
let build_sdiv ?(name = "") l r = build_sdiv l r name builder
let build_icmp ?(name = "") op l r = build_icmp op l r name builder
let build_pointercast ?(name = "") f typ = Llvm.build_pointercast f typ name builder
let build_ret v = build_ret v builder
let build_br bb = build_br bb builder
let build_cond_br c tb fb = build_cond_br c tb fb builder
let build_phi ?(name = "") rules = build_phi rules name builder
let build_array_alloca ?(name = "") typ n = Llvm.build_array_alloca typ n name builder
let build_gep ?(name = "") v ind = Llvm.build_gep (type_of v) v ind name builder
let set_metadata v kind fmt =
Format.kasprintf
(fun s ->
Llvm.set_metadata v (Llvm.mdkind_id context kind) (Llvm.mdstring context s);
v)
fmt
;;
let position_at_end bb = Llvm.position_at_end bb builder
let insertion_block () = Llvm.insertion_block builder
let append_block ?(name = "") f = Llvm.append_block context name f
(* Aliases *)
let block_parent = Llvm.block_parent
let entry_block = Llvm.entry_block
let void_type = Llvm.void_type context
let i64_type = Llvm.i64_type context
let i1_type = Llvm.i1_type context
let ptr_type = Llvm.pointer_type context
let function_type = Llvm.function_type
let const_int = Llvm.const_int
let params = Llvm.params
let pp_value ppf x = Format.fprintf ppf "%s" (Llvm.string_of_llvalue x)
end
in
(module L : S)
;;