Commits

camlspotter  committed 1a0bc84

gep_load and gep_store

  • Participants
  • Parent commits 15547e2

Comments (0)

Files changed (3)

     unsafeM (Llvm.build_gep !<v (Array.of_list (List.map (!<) xs)) name)
 
   module Gep : sig
-    type 'a t
-    val gep : ?name:string -> 'a pointer v -> ('a pointer t -> 'b) -> 'b
-    val end_ : 'a t -> 'a pointer v m
-    val load : ?name:string -> unit -> 'a t -> 'a v m
-    val store : 'a v -> 'a t -> unit m 
-    val pos_const : int -> [> `container of 'a] t -> ('a t -> 'b) -> 'b
-    val pos : i32 v -> [> `container of 'a] t -> ('a t -> 'b) -> 'b
-    val mem0 : ('a0 * _) struct_ t -> ('a0 t -> 'b) -> 'b
-    val mem1 : (_ * ('a1 * _)) struct_ t -> ('a1 t -> 'b) -> 'b
-    val mem2 : (_ * (_ * ('a2 * _))) struct_ t -> ('a2 t -> 'b) -> 'b
-    val mem3 : (_ * (_ * (_ * ('a3 * _)))) struct_ t -> ('a3 t -> 'b) -> 'b
-    val mem4 : (_ * (_ * (_ * (_ * ('a4 * _))))) struct_ t -> ('a4 t -> 'b) -> 'b
-    val mem5 : (_ * (_ * (_ * (_ * (_ * ('a5 * _)))))) struct_ t -> ('a5 t -> 'b) -> 'b
-    val mem6 : (_ * (_ * (_ * (_ * (_ * (_ * ('a6 * _))))))) struct_ t -> ('a6 t -> 'b) -> 'b
-    val mem7 : (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a7 * _)))))))) struct_ t -> ('a7 t -> 'b) -> 'b
-    val mem8 : (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a8 * _))))))))) struct_ t -> ('a8 t -> 'b) -> 'b
-    val mem9 : (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a9 * _)))))))))) struct_ t -> ('a9 t -> 'b) -> 'b
+    type ('a, 'res) t
+    val gep_gen : ?name:string -> ('x pointer v -> 'y m) -> 'a pointer v -> (('a pointer, 'x pointer v -> 'y m) t -> 'b) -> 'b
+    val end_ : ('a, 'a pointer v -> 'res m) t -> 'res m
+    val pos_const : int -> ([> `container of 'a], 'res) t -> (('a, 'res) t -> 'b) -> 'b
+    val pos : i32 v -> ([> `container of 'a], 'res) t -> (('a, 'res) t -> 'b) -> 'b
+    val mem0 : (('a0 * _) struct_, 'res) t -> (('a0, 'res) t -> 'b) -> 'b
+    val mem1 : ((_ * ('a1 * _)) struct_, 'res) t -> (('a1, 'res) t -> 'b) -> 'b
+    val mem2 : ((_ * (_ * ('a2 * _))) struct_, 'res) t -> (('a2, 'res) t -> 'b) -> 'b
+    val mem3 : ((_ * (_ * (_ * ('a3 * _)))) struct_, 'res) t -> (('a3, 'res) t -> 'b) -> 'b
+    val mem4 : ((_ * (_ * (_ * (_ * ('a4 * _))))) struct_, 'res) t -> (('a4, 'res) t -> 'b) -> 'b
+    val mem5 : ((_ * (_ * (_ * (_ * (_ * ('a5 * _)))))) struct_, 'res) t -> (('a5, 'res) t -> 'b) -> 'b
+    val mem6 : ((_ * (_ * (_ * (_ * (_ * (_ * ('a6 * _))))))) struct_, 'res) t -> (('a6, 'res) t -> 'b) -> 'b
+    val mem7 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a7 * _)))))))) struct_, 'res) t -> (('a7, 'res) t -> 'b) -> 'b
+    val mem8 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a8 * _))))))))) struct_, 'res) t -> (('a8, 'res) t -> 'b) -> 'b
+    val mem9 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a9 * _)))))))))) struct_, 'res) t -> (('a9, 'res) t -> 'b) -> 'b
   end = struct
-    type 'a t = (i32 v list -> unknown pointer v m) * i32 v list
-    let gep ?name (v : 'a pointer v) = 
-      let do_gep = unsafe_gep ?name v in
-      fun f -> f (do_gep, [])
-    let end_ (do_gep, rev_idx : 'a t) = magicM ^$ do_gep (List.rev rev_idx)
-    let load ?name () at = perform
-      ptr <-- end_ at;
-      load ?name ptr
-    let store v at = perform
-      ptr <-- end_ at;
-      store v ~dst:ptr
+    type ('a, 'res) t = { gep : i32 v list -> unknown pointer v m; 
+                          rev : i32 v list; 
+                          k : 'res }
+    let gep_gen ?name cont v f =
+      f { gep = unsafe_gep ?name v; rev = []; k = cont; }
+    let end_ st = perform
+      ptr <--  st.gep (List.rev st.rev);
+      st.k (P.magic ptr : 'a pointer v)
       
-    let pos_const (n : int) (do_gep, st) (k : 'a t -> 'b) = 
-      k (do_gep, Const.i32_of_int n::st)
-    let pos (n : i32 v) (do_gep, st) (k : 'a t -> 'b) = 
-      k (do_gep, n::st)
-    let mem0  (do_gep, st : _ t) k = k (do_gep, Const.i32_of_int 0  :: st : _ t)
-    let mem1  (do_gep, st : _ t) k = k (do_gep, Const.i32_of_int 1  :: st : _ t)
-    let mem2  (do_gep, st : _ t) k = k (do_gep, Const.i32_of_int 2  :: st : _ t)
-    let mem3  (do_gep, st : _ t) k = k (do_gep, Const.i32_of_int 3  :: st : _ t)
-    let mem4  (do_gep, st : _ t) k = k (do_gep, Const.i32_of_int 4  :: st : _ t)
-    let mem5  (do_gep, st : _ t) k = k (do_gep, Const.i32_of_int 5  :: st : _ t)
-    let mem6  (do_gep, st : _ t) k = k (do_gep, Const.i32_of_int 6  :: st : _ t)
-    let mem7  (do_gep, st : _ t) k = k (do_gep, Const.i32_of_int 7  :: st : _ t)
-    let mem8  (do_gep, st : _ t) k = k (do_gep, Const.i32_of_int 8  :: st : _ t)
-    let mem9  (do_gep, st : _ t) k = k (do_gep, Const.i32_of_int 9  :: st : _ t)
+    let pos_const (n : int) st k = k { st with rev = Const.i32_of_int n::st.rev }
+    let pos (n : i32 v) st k = k { st with rev = n::st.rev }
+    let mem0 st k = k { st with rev = Const.i32_of_int 0  :: st.rev }
+    let mem1 st k = k { st with rev = Const.i32_of_int 1  :: st.rev }
+    let mem2 st k = k { st with rev = Const.i32_of_int 2  :: st.rev }
+    let mem3 st k = k { st with rev = Const.i32_of_int 3  :: st.rev }
+    let mem4 st k = k { st with rev = Const.i32_of_int 4  :: st.rev }
+    let mem5 st k = k { st with rev = Const.i32_of_int 5  :: st.rev }
+    let mem6 st k = k { st with rev = Const.i32_of_int 6  :: st.rev }
+    let mem7 st k = k { st with rev = Const.i32_of_int 7  :: st.rev }
+    let mem8 st k = k { st with rev = Const.i32_of_int 8  :: st.rev }
+    let mem9 st k = k { st with rev = Const.i32_of_int 9  :: st.rev }
   end
 
-  let gep = Gep.gep
+  let gep ?name v = Gep.gep_gen ?name return v
+  let gep_load ?name v = Gep.gep_gen (load ?name) v
+  let gep_store x ~dst:v = Gep.gep_gen (fun ptr -> store x ~dst:ptr) v
 
   let ret x : unit m = Monad.ignore (Llvm.build_ret !<x)
   let ret_void : unit m = Monad.ignore Llvm.build_ret_void

File lbuilder_intf.ml

   val unsafe_gep : ?name:string -> 'a pointer v -> i32 v list -> 'unsafe pointer v m
 
   module Gep : sig
-    type 'a t (** a phantom for type safe GEP *)
-    val end_ : 'a t -> 'a pointer v m
-    val load : ?name:string -> unit -> 'a t -> 'a v m
-    val store : 'a v -> 'a t -> unit m 
-    val pos_const : int -> [> `container of 'a] t -> ('a t -> 'b) -> 'b
-    val pos : i32 v -> [> `container of 'a] t -> ('a t -> 'b) -> 'b
-    val mem0 : ('a0 * _) struct_ t -> ('a0 t -> 'b) -> 'b
-    val mem1 : (_ * ('a1 * _)) struct_ t -> ('a1 t -> 'b) -> 'b
-    val mem2 : (_ * (_ * ('a2 * _))) struct_ t -> ('a2 t -> 'b) -> 'b
-    val mem3 : (_ * (_ * (_ * ('a3 * _)))) struct_ t -> ('a3 t -> 'b) -> 'b
-    val mem4 : (_ * (_ * (_ * (_ * ('a4 * _))))) struct_ t -> ('a4 t -> 'b) -> 'b
-    val mem5 : (_ * (_ * (_ * (_ * (_ * ('a5 * _)))))) struct_ t -> ('a5 t -> 'b) -> 'b
-    val mem6 : (_ * (_ * (_ * (_ * (_ * (_ * ('a6 * _))))))) struct_ t -> ('a6 t -> 'b) -> 'b
-    val mem7 : (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a7 * _)))))))) struct_ t -> ('a7 t -> 'b) -> 'b
-    val mem8 : (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a8 * _))))))))) struct_ t -> ('a8 t -> 'b) -> 'b
-    val mem9 : (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a9 * _)))))))))) struct_ t -> ('a9 t -> 'b) -> 'b
+    type ('a, 'res) t (** phantom for type safe GEP *)
+    val gep_gen : ?name:string -> ('x pointer v -> 'y m) -> 'a pointer v -> (('a pointer, 'x pointer v -> 'y m) t -> 'b) -> 'b
+    val end_ : ('a, 'a pointer v -> 'res m) t -> 'res m
+    val pos_const : int -> ([> `container of 'a], 'res) t -> (('a, 'res) t -> 'b) -> 'b
+    val pos : i32 v -> ([> `container of 'a], 'res) t -> (('a, 'res) t -> 'b) -> 'b
+    val mem0 : (('a0 * _) struct_, 'res) t -> (('a0, 'res) t -> 'b) -> 'b
+    val mem1 : ((_ * ('a1 * _)) struct_, 'res) t -> (('a1, 'res) t -> 'b) -> 'b
+    val mem2 : ((_ * (_ * ('a2 * _))) struct_, 'res) t -> (('a2, 'res) t -> 'b) -> 'b
+    val mem3 : ((_ * (_ * (_ * ('a3 * _)))) struct_, 'res) t -> (('a3, 'res) t -> 'b) -> 'b
+    val mem4 : ((_ * (_ * (_ * (_ * ('a4 * _))))) struct_, 'res) t -> (('a4, 'res) t -> 'b) -> 'b
+    val mem5 : ((_ * (_ * (_ * (_ * (_ * ('a5 * _)))))) struct_, 'res) t -> (('a5, 'res) t -> 'b) -> 'b
+    val mem6 : ((_ * (_ * (_ * (_ * (_ * (_ * ('a6 * _))))))) struct_, 'res) t -> (('a6, 'res) t -> 'b) -> 'b
+    val mem7 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a7 * _)))))))) struct_, 'res) t -> (('a7, 'res) t -> 'b) -> 'b
+    val mem8 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a8 * _))))))))) struct_, 'res) t -> (('a8, 'res) t -> 'b) -> 'b
+    val mem9 : ((_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * (_ * ('a9 * _)))))))))) struct_, 'res) t -> (('a9, 'res) t -> 'b) -> 'b
   end 
 
-  val gep : ?name:string -> 'a pointer v -> ('a pointer Gep.t -> 'b) -> 'b
+  val gep : ?name:string 
+            -> 'a pointer v
+            -> (('a pointer, 'x pointer v -> 'x pointer v m) Gep.t -> 'b)
+            -> 'b
+  val gep_load : ?name:string 
+            -> 'a pointer v
+            -> (('a pointer, 'x pointer v -> 'x v m) Gep.t -> 'b)
+            -> 'b
+  val gep_store : 'x v
+            -> dst:'a pointer v
+            -> (('a pointer, 'x pointer v -> unit m) Gep.t -> 'b)
+            -> 'b
 
   val load : ?name:string -> 'a pointer v -> 'a v m
   val store : 'a v -> dst:'a pointer v -> unit m
     | 0 -> fprintf ppf "('a%d * _)" n
     | n -> fprintf ppf "(_ * %a)" g (n-1)
   in
-  fprintf ppf "val mem%d : %a struct_ t -> ('a%d t -> 'b) -> 'b@."
+  fprintf ppf "val mem%d : (%a struct_, 'res) t -> (('a%d, 'res) t -> 'b) -> 'b@."
     n
     g n
     n