Source

ocaml-llvm-phantom / lib / value_ctxt.ml

open Llvm
open Spotlib.Spot
open Type
(* open Value *)

module P = Phantom
open P.Open

module Make(A : sig val context : Context.t end) = struct
  include A
  include Value

  type ('a, 'final, 'res) gep_t = ('a, 'final, 'res) Gep.t

  module Type = Type_ctxt.Make(A)

  module Const = struct
    let int v : [`int] v = P.unsafe ^$ const_int (if Sys.word_size = 32 then !<Type.i32 else !<Type.i64) v
    let nativeint n : [`int] v = 
      P.unsafe ^$ const_of_int64 (if Sys.word_size = 32 then !<Type.i32 else !<Type.i64) (Int64.of_nativeint n) false
    let i32 n : i32 v = P.unsafe ^$ const_of_int64 (!<Type.i32) (Int64.of_int32 n) false
    let i32_of_int n : i32 v = P.unsafe ^$ const_of_int64 (!<Type.i32) (Int64.of_int n) false
    let i32_0 = i32_of_int 0
    let i32_1 = i32_of_int 1
    let i64 n : i64 v = P.unsafe ^$ const_of_int64 (!<Type.i64) n false
    let double f : double v = P.unsafe ^$ const_float (!<Type.double) f
    let bool b : i1 v = P.unsafe ^$ const_int (!<Type.i1) (if b then 1 else 0)
  
    let bitcast v (ty : 'typ typ) : 'typ v = P.unsafe ^$ const_bitcast !<v !<ty
    let intcast (v : [>`int] v) (ty : ([>`int] as 'typ) typ) : 'typ v = P.unsafe ^$ const_intcast !<v !<ty
    let ptrtoint (v : 'a pointer v) (ty : ([>`int] as 'typ) typ) : 'typ v = P.unsafe ^$ const_ptrtoint !<v !<ty
    let null (ty : 'typ typ) : 'typ v = P.unsafe ^$ const_null !<ty
  
    let unsafe_gep v ints = 
      P.unsafe ^$ const_gep !<v (Array.of_list (List.map (fun x -> !<(i32_of_int x)) ints))

    let gep_gen cont v = Gep.gen (fun lst ->
        let lst = List.map (function
          | `int n -> n
          | `llvalue _ -> assert false (* it must be constants *)) lst
        in
        cont (unsafe_gep v lst))

    let gep v = gep_gen (fun x -> x) v

    let offset_of ty indices =
      (* CR jfuruse: only for 32 bit arch! *)
      ptrtoint (unsafe_gep (null (Type.pointer ty)) indices) Type.i32
  end
  
  (* CR: size of is defined here, where value is available *)
  let size_i64_of ty : i64 v = P.unsafe ^$ Llvm.size_of !<ty
  let size_of ty : i32 v = Const.intcast (size_i64_of ty) Type.i32

  module Analysis = struct
    let assert_valid_function (v : ('a -> 'b) pointer v) = Llvm_analysis.assert_valid_function !<v
  end
end