Commits

camlspotter  committed ff052af

reorg

  • Participants
  • Parent commits 425c67b

Comments (0)

Files changed (2)

 
   module Module = Module
 
-  let create () = Llvm.builder Module.context
+  (** Builder monad *)
 
   (* CR jfuruse: Builder is independent from Module. It can be somewhere else. *)
   module Monad = struct
     include Builder
-    let run v = v (create ())
+    let run v = v (Llvm.builder Module.context)
   end
+  type 'a m = 'a Monad.t
+  let build = Monad.run
+  let unknownM (v : 'a v m) : unknown v m = v >>= fun v -> return (!?v)
+  let magicM (v : 'a v m) : 'b v m = perform v <-- v; return (P.magic v)
+  let unsafeM v = perform v <-- v; return (P.unsafe v)
 
-  type 'a m = 'a Monad.t
-
-  let build = Monad.run
-
-  let unknownM (v : 'a v m) : unknown v m = 
-    v >>= fun v -> return (!?v)
-    
-  let magicM (v : 'a v m) : 'b v m = perform
-    v <-- v;
-    return (P.magic v)
-
-  let unsafeM v = perform
-    v <-- v;
-    return (P.unsafe v)
+  (** Function calls *)
 
   let call 
       ?(name="called") (* CR jfuruse: called + f's name *)
     unsafeM (Llvm.build_call !<f (Array.of_list (P.List.to_list args 
                                             @ List.map (!<) va_args)) name)
 
+
+  (** String *)
+
   let global_stringptr ?(name="stringptr") str : i8 pointer v m = 
     unsafeM (Llvm.build_global_stringptr str name)
 
+  (** Pointers *)
+
+  let is_null ?(name="is_null") (lv : 'a pointer v) : i1 v m = 
+    unsafeM (Llvm.build_is_null !<lv name)
+
+  (** Casts *)
+
   let bitcast 
       ?(name="bitcast") 
       (v : 'a v) 
       : 'ty v m =
     unsafeM (Llvm.build_pointercast !<v !<ty name)
 
+  let cast_name v lty =
+    let name = Value.name v in
+    let name = try String.sub name 0 (String.rindex name '=') with Not_found -> name in
+    name ^ "=" ^ Type.string_of lty
+
+  (* CR: bitcast is wrapped again! *)
+  let bitcast ?name v lty = 
+    let name = match name with
+      | Some n -> n
+      | None -> cast_name v lty
+    in
+    bitcast ~name v lty
+
+  (* CR pointercast is wrapped again! *)
+  let pointercast ?name v lty = 
+    let name = match name with
+      | Some n -> n
+      | None -> cast_name v lty
+    in
+    pointercast ~name v lty
+
+  (** Load/Store. Unsafe and type-safe versions *)
+
   let load 
       ?(name="loaded")
       (v : 'ty pointer v)
   let gep_load ?name v = gep_gen (load ?name) v
   let gep_store x ~dst:v = 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
+  let unsafe_const_load ?name ptr indices = perform
+    gepped <-- unsafe_gep ~name:"for_load" ptr (List.map Const.i32_of_int indices);
+    load ?name gepped
 
-  let phi 
-      ?(name="phi")
-      (lst : ('a v * Llvm.llbasicblock) list)
-      : 'a v m =
-    unsafeM (Llvm.build_phi (List.map (fun (v, b) -> !<v, b) lst) name)
+  (* opposite order! *)
+  let unsafe_const_store ptr indices lv = perform
+      gepped <-- unsafe_gep ~name:"for_store" ptr (List.map Const.i32_of_int indices);
+      Monad.ignore (store lv ~dst:gepped)
 
-  let cond_br 
-      (b : i1 v)
-      bthen belse
-      : unit m
-      = Monad.ignore (Llvm.build_cond_br !<b bthen belse)
-
-  let br b = Monad.ignore (Llvm.build_br b)
-
-  let is_null ?(name="is_null") (lv : 'a pointer v) : i1 v m = 
-    unsafeM (Llvm.build_is_null !<lv name)
+  (** Arithmetic operations *)
 
   (* CR jfuruse: unfortunately no arith type check is done yet *)      
   let arith (defname : string) f = 
   let icmp c = cmp "icmped" (Llvm.build_icmp c)
   let fcmp c = cmp "fcmped" (Llvm.build_fcmp c)
 
+  (** Useful libc functions *)
+
   let printf : string -> unknown v list -> unit m = 
     fun fmt args -> perform
       fmt <-- global_stringptr ~name:"fmt" fmt;
       Monad.ignore (call_va_args (Module.External.printf) (P.c1 fmt) args ~name:"res")
   ;;
 
-  let cast_name v lty =
-    let name = Value.name v in
-    let name = try String.sub name 0 (String.rindex name '=') with Not_found -> name in
-    name ^ "=" ^ Type.string_of lty
-
-  (* CR: bitcast is wrapped again! *)
-  let bitcast ?name v lty = 
-    let name = match name with
-      | Some n -> n
-      | None -> cast_name v lty
-    in
-    bitcast ~name v lty
-
-  (* CR pointercast is wrapped again! *)
-  let pointercast ?name v lty = 
-    let name = match name with
-      | Some n -> n
-      | None -> cast_name v lty
-    in
-    pointercast ~name v lty
-
   let memcpy ~dst ~src ~size = call ~name:"copied" Module.External.memcpy (P.c3 dst src size)
 
   let bzero dst ~size = Monad.ignore (call Module.External.bzero (P.c2 dst size))
     Monad.ignore (call Module.External.free (P.c1 ptr))
   ;;
 
-  let unsafe_const_load ?name ptr indices = perform
-    gepped <-- unsafe_gep ~name:"for_load" ptr (List.map Const.i32_of_int indices);
-    load ?name gepped
+  (** Control flow codegens *)
 
-  (* opposite order! *)
-  let unsafe_const_store ptr indices lv = perform
-      gepped <-- unsafe_gep ~name:"for_store" ptr (List.map Const.i32_of_int indices);
-      Monad.ignore (store lv ~dst:gepped)
+  let ret x : unit m = Monad.ignore (Llvm.build_ret !<x)
+  let ret_void : unit m = Monad.ignore Llvm.build_ret_void
+
+  let phi 
+      ?(name="phi")
+      (lst : ('a v * Llvm.llbasicblock) list)
+      : 'a v m =
+    unsafeM (Llvm.build_phi (List.map (fun (v, b) -> !<v, b) lst) name)
+
+  let cond_br 
+      (b : i1 v)
+      bthen belse
+      : unit m
+      = Monad.ignore (Llvm.build_cond_br !<b bthen belse)
+
+  let br b = Monad.ignore (Llvm.build_br b)
+
+  (** Basic blocks *)
 
   module Block = struct
     let position_at_end = Llvm.position_at_end
       (* \ Format.eprintf "Created function %s@." name; *)
       return lv_f
 
-  let return_void : void v m = (fun _builder -> P.magic Const.i32_0)
-    (* The return value looks strange but probably ok. Probably. *)
-
   (* stupid lambda abstraction is required for polymorphism *)    
   let current_function : unit -> ('a -> 'b) pointer v m = fun () -> perform
     current_bb <-- Block.insertion;
     new_bb <-- Block.insertion;
     return (bb, res, new_bb)
 
+  (** Connecting basic blocks *)
+
+  let return_void : void v m = (fun _builder -> P.magic Const.i32_0)
+    (* The return value looks strange but probably ok. Probably. *)
+
   let uncond_br from to_ = perform
     Block.position_at_end from;
     Monad.ignore (br to_)
 
     return ()
 
+  (** Execution *)
+
   let exec =
     let cntr = ref 0 in
     fun (v : unit m) ->

File build_intf.ml

 
 module type S = sig
 
-  (** Monad for builder *)    
+  (** Builder monad *)
+
   module Monad : sig
     include Monad_intf.T with type 'a t = Llvm.llbuilder -> 'a
     val run : 'a t -> 'a
   val unknownM : 'a v m -> unknown v m
   val magicM : 'a v m -> 'b v m
 
+
+
+  (** Function calls *)
+
   val call : ?name:string -> ('a -> 'b) pointer v -> 'a vs -> 'b v m
   val call_va_args : ?name: string -> ('a -> dots -> 'b) pointer v -> 'a vs -> unknown v list -> 'b v m
 
+
+
+  (** String *)
   val global_stringptr : ?name:string -> string -> i8 pointer v m
 
+
+
+  (** Pointers *)
+
+  val is_null : ?name:string -> 'a pointer v -> i1 v m
+
+
+
+  (** Casts *)
+
+  val bitcast : ?name:string -> 'a v -> 'b typ -> 'b v m
+  val pointercast : ?name:string -> 'a pointer v -> ([>`int] as 'b) typ -> 'b v m
+
+
+
+  (** Load/Store. Unsafe and type-safe versions *)
+
   val unsafe_gep : ?name:string -> 'a pointer v -> i32 v list -> 'unsafe pointer v m
     
   (** Type-safe GEP
 
   val load : ?name:string -> 'a pointer v -> 'a v m
   val store : 'a v -> dst:'a pointer v -> unit m
-    
-  val ret : 'a v -> unit m
-  val ret_void : unit m
-    
-  val phi : ?name:string -> ('a v * Llvm.llbasicblock) list -> 'a v m
 
-  val cond_br : i1 v -> Llvm.llbasicblock -> Llvm.llbasicblock -> unit m
+  val unsafe_const_load : ?name:string -> 'a pointer v -> int list -> 'unsafe v m
+  val unsafe_const_store : 'a pointer v -> int list -> 'unsafe v -> unit m
 
-  val br : Llvm.llbasicblock -> unit m
 
-  val is_null : ?name:string -> 'a pointer v -> i1 v m
+
+  (** Arithmetic operations *)
 
   val add :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
   val sub :  ?name:string -> ([>`int] as 'a) v -> 'a v -> 'a v m
   val icmp : Llvm.Icmp.t -> ?name:string -> ([>`int] as 'a) v -> 'a v -> i1 v m
   val fcmp : Llvm.Fcmp.t -> ?name:string -> ([>`floating] as 'a) v -> 'a v -> i1 v m
 
+  (** Useful libc functions *)
+
   val printf : string -> unknown v list -> unit m
     (* CR jfuruse: probably (quite unlikely though), we can have a type safer version *)
 
-  val bitcast : ?name:string -> 'a v -> 'b typ -> 'b v m
-  val pointercast : ?name:string -> 'a pointer v -> ([>`int] as 'b) typ -> 'b v m
-
   val malloc : ?name:string -> ?bzero:bool -> i32 v -> void_pointer v m
     (** malloc by size. *)
 
   val bzero : void_pointer v -> size:i32 v -> unit m
   val free : 'a pointer v -> unit m
 
-  val unsafe_const_load : ?name:string -> 'a pointer v -> int list -> 'unsafe v m
-  val unsafe_const_store : 'a pointer v -> int list -> 'unsafe v -> unit m
+
+  (** Control flow codegens *)
+
+  val ret : 'a v -> unit m
+  val ret_void : unit m
+    
+  val phi : ?name:string -> ('a v * Llvm.llbasicblock) list -> 'a v m
+
+  val cond_br : i1 v -> Llvm.llbasicblock -> Llvm.llbasicblock -> unit m
+
+  val br : Llvm.llbasicblock -> unit m
+
+
+
+  (** Basic blocks *)
 
   module Block : sig
     val position_at_end : Llvm.llbasicblock -> unit m
     val parent : Llvm.llbasicblock -> ('a -> 'b) pointer v
   end
 
+
+
+  (** Function definition *)
+
   val func : string -> 'a typ -> ('b, (string * Llvm.lltype)) Phantom.ts
     -> ?dump: bool
     -> (('b -> 'a) pointer v (* self *) -> 'b vs -> 'a v m) 
       Self is for recursion.
   *)
 
+
+
+  (** Connecting basic blocks *)
+
   val return_void : void v m 
   (** for functions returning void *)
 
     -> unit m
   (** Not_found is raised if not defined in a function *)
 
+
+
+  (** Execution *)
+
   val exec : unit m -> unit
-    (** [exec u] creates an anonymous function from [u] and runs it. *)
+  (** [exec u] creates an anonymous function from [u] and runs it. *)
 end