+external block_begin : llvalue -> (llvalue, llbasicblock) llpos
+ = "llvm_block_begin"
+external block_succ : llbasicblock -> (llvalue, llbasicblock) llpos
+ = "llvm_block_succ"
+external block_end : llvalue -> (llvalue, llbasicblock) llrev_pos
+ = "llvm_block_end"
+external block_pred : llbasicblock -> (llvalue, llbasicblock) llrev_pos
+ = "llvm_block_pred"
+external block_terminator : llbasicblock -> llvalue option =
+ "llvm_block_terminator"
+
+let rec iter_block_range f i e =
+ if i = e then () else
+ match i with
+ | At_end _ -> raise (Invalid_argument "Invalid block range.")
+ | Before bb ->
+ f bb;
+ iter_block_range f (block_succ bb) e
+
+let iter_blocks f fn =
+ iter_block_range f (block_begin fn) (At_end fn)
+
+let rec fold_left_block_range f init i e =
+ if i = e then init else
+ match i with
+ | At_end _ -> raise (Invalid_argument "Invalid block range.")
+ | Before bb -> fold_left_block_range f (f init bb) (block_succ bb) e
+
+let fold_left_blocks f init fn =
+ fold_left_block_range f init (block_begin fn) (At_end fn)
+
+let rec rev_iter_block_range f i e =
+ if i = e then () else
+ match i with
+ | At_start _ -> raise (Invalid_argument "Invalid block range.")
+ | After bb ->
+ f bb;
+ rev_iter_block_range f (block_pred bb) e
+
+let rev_iter_blocks f fn =
+ rev_iter_block_range f (block_end fn) (At_start fn)
+
+let rec fold_right_block_range f init i e =
+ if i = e then init else
+ match i with
+ | At_start _ -> raise (Invalid_argument "Invalid block range.")
+ | After bb -> fold_right_block_range f (f bb init) (block_pred bb) e
+
+let fold_right_blocks f fn init =
+ fold_right_block_range f init (block_end fn) (At_start fn)
+
+(*--... Operations on instructions .........................................--*)
+external instr_parent : llvalue -> llbasicblock = "LLVMGetInstructionParent"
+external instr_begin : llbasicblock -> (llbasicblock, llvalue) llpos
+ = "llvm_instr_begin"
+external instr_succ : llvalue -> (llbasicblock, llvalue) llpos
+ = "llvm_instr_succ"
+external instr_end : llbasicblock -> (llbasicblock, llvalue) llrev_pos
+ = "llvm_instr_end"
+external instr_pred : llvalue -> (llbasicblock, llvalue) llrev_pos
+ = "llvm_instr_pred"
+
+external instr_opcode : llvalue -> Opcode.t = "llvm_instr_get_opcode"
+external icmp_predicate : llvalue -> Icmp.t option = "llvm_instr_icmp_predicate"
+external fcmp_predicate : llvalue -> Fcmp.t option = "llvm_instr_fcmp_predicate"
+external instr_clone : llvalue -> llvalue = "llvm_instr_clone"
+
+let rec iter_instrs_range f i e =
+ if i = e then () else
+ match i with
+ | At_end _ -> raise (Invalid_argument "Invalid instruction range.")
+ | Before i ->
+ f i;
+ iter_instrs_range f (instr_succ i) e
+
+let iter_instrs f bb =
+ iter_instrs_range f (instr_begin bb) (At_end bb)
+
+let rec fold_left_instrs_range f init i e =
+ if i = e then init else
+ match i with
+ | At_end _ -> raise (Invalid_argument "Invalid instruction range.")
+ | Before i -> fold_left_instrs_range f (f init i) (instr_succ i) e
+
+let fold_left_instrs f init bb =
+ fold_left_instrs_range f init (instr_begin bb) (At_end bb)
+
+let rec rev_iter_instrs_range f i e =
+ if i = e then () else
+ match i with
+ | At_start _ -> raise (Invalid_argument "Invalid instruction range.")
+ | After i ->
+ f i;
+ rev_iter_instrs_range f (instr_pred i) e
+
+let rev_iter_instrs f bb =
+ rev_iter_instrs_range f (instr_end bb) (At_start bb)
+
+let rec fold_right_instr_range f i e init =
+ if i = e then init else
+ match i with
+ | At_start _ -> raise (Invalid_argument "Invalid instruction range.")
+ | After i -> fold_right_instr_range f (instr_pred i) e (f i init)
+
+let fold_right_instrs f bb init =
+ fold_right_instr_range f (instr_end bb) (At_start bb) init
+
+
+(*--... Operations on call sites ...........................................--*)
+external instruction_call_conv: llvalue -> int
+ = "llvm_instruction_call_conv"
+external set_instruction_call_conv: int -> llvalue -> unit
+ = "llvm_set_instruction_call_conv"
+
+external llvm_add_instruction_param_attr : llvalue -> int -> int32 -> unit
+ = "llvm_add_instruction_param_attr"
+external llvm_remove_instruction_param_attr : llvalue -> int -> int32 -> unit
+ = "llvm_remove_instruction_param_attr"
+
+let add_instruction_param_attr llval i attr =
+ llvm_add_instruction_param_attr llval i (pack_attr attr)
+
+let remove_instruction_param_attr llval i attr =
+ llvm_remove_instruction_param_attr llval i (pack_attr attr)
+
+(*--... Operations on call instructions (only) .............................--*)
+external is_tail_call : llvalue -> bool = "llvm_is_tail_call"
+external set_tail_call : bool -> llvalue -> unit = "llvm_set_tail_call"
+
+(*--... Operations on load/store instructions (only) .......................--*)
+external is_volatile : llvalue -> bool = "llvm_is_volatile"
+external set_volatile : bool -> llvalue -> unit = "llvm_set_volatile"
+
+(*--... Operations on terminators ..........................................--*)
+
+let is_terminator llv =
+ let open ValueKind in
+ let open Opcode in
+ match classify_value llv with
+ | Instruction (Br | IndirectBr | Invoke | Resume | Ret | Switch | Unreachable)
+ -> true
+ | _ -> false
+
+external successor : llvalue -> int -> llbasicblock = "llvm_successor"
+external set_successor : llvalue -> int -> llbasicblock -> unit
+ = "llvm_set_successor"
+external num_successors : llvalue -> int = "llvm_num_successors"
+
+let successors llv =
+ if not (is_terminator llv) then
+ raise (Invalid_argument "Llvm.successors can only be used on terminators")
+ else
+ Array.init (num_successors llv) (successor llv)
+
+let iter_successors f llv =
+ if not (is_terminator llv) then
+ raise (Invalid_argument "Llvm.iter_successors can only be used on terminators")
+ else
+ for i = 0 to num_successors llv - 1 do
+ f (successor llv i)
+ done
+
+let fold_successors f llv z =
+ if not (is_terminator llv) then
+ raise (Invalid_argument "Llvm.fold_successors can only be used on terminators")
+ else
+ let n = num_successors llv in
+ let rec aux i acc =
+ if i >= n then acc
+ else begin
+ let llb = successor llv i in
+ aux (i+1) (f llb acc)
+ end
+ in aux 0 z
+
+
+(*--... Operations on branches .............................................--*)
+external condition : llvalue -> llvalue = "llvm_condition"
+external set_condition : llvalue -> llvalue -> unit
+ = "llvm_set_condition"
+external is_conditional : llvalue -> bool = "llvm_is_conditional"
+
+let get_branch llv =
+ if classify_value llv <> ValueKind.Instruction Opcode.Br then
+ None
+ else if is_conditional llv then
+ Some (`Conditional (condition llv, successor llv 0, successor llv 1))
+ else
+ Some (`Unconditional (successor llv 0))