camlspotter avatar camlspotter committed 4f9dbe9

added offset_of, for_loop and so on

Comments (0)

Files changed (6)

     let parent bb : ('a -> 'b) pointer t = Value.unsafe (Llvm.block_parent bb)
   end
 
-  let func name (ty_ret : 'ret typ) (args : 'args Ltype.Base.WithString.ts) (f : 'args vs -> 'ret v m) : ('args -> 'ret) pointer v m =
+  let func name (ty_ret : 'ret typ) (args : 'args Ltype.Base.WithString.ts) 
+      (f : ('args -> 'ret) pointer v -> 'args vs -> 'ret v m) : ('args -> 'ret) pointer v m =
     Format.eprintf "Creating function %s@." name;
     let lty = function_ ty_ret (Ltype.Base.WithString.types args) in
     let lv_f = match Module.Function.lookup name with
     let bb = Block.append ~name:"entry" lv_f in
     perform 
       Block.position_at_end bb;
-      lv_body <-- f (function_params lv_f);
+      lv_body <-- f lv_f (function_params lv_f);
       (* Finish off the function. *)
       if classify ty_ret = Llvm.TypeKind.Void then ret_void else ret lv_body;
       (* Validate the generated code, checking for consistency. *)
   let return_void : void v m = (fun _builder -> magic Const.i32_0)
     (* The return value looks strange but probably ok. Probably. *)
 
-  let if_then_else (f_lv_cond : i1 v m) (f_lv_then : 'a v m) (f_lv_else : 'a v m) : 'a v m = perform
+  (* stupid lambda abstraction is required for polymorphism *)    
+  let current_function : unit -> ('a -> 'b) pointer v m = fun () -> perform
+    current_bb <-- Block.insertion;
+    return (Block.parent current_bb)
+
+  let append_code_block name (vm : 'a v m) : (Llvm.llbasicblock * 'a v * Llvm.llbasicblock) m = perform
+    the_function <-- current_function ();
+    let bb = Block.append ~name the_function in
+    (* Emit value. *)
+    Block.position_at_end bb;
+    v <-- vm;
+    (* Codegen of [v] can change the current block, update bb for the phi. *)
+    new_bb <-- Block.insertion;
+    return (bb, v, new_bb)
+
+  let uncond_br from to_ = perform
+    Block.position_at_end from;
+    Monad.ignore (br to_)
+
+  let if_then_else (lv_cond : i1 v m) (lv_then : 'a v m) (lv_else : 'a v m) : 'a v m = perform
     (* get the current bb *)
     start_bb <-- Block.insertion;
-    (* get the function being defined *)
-    let the_function = Block.parent start_bb in
-    lv_cond <-- f_lv_cond; (* created in [start_bb] *)
+
+    lv_cond <-- lv_cond; (* created in [start_bb] *)
     (* before adding branching, we must create the destinations *)
 
-    let then_bb = Block.append ~name:"then" the_function in
-    (* Emit 'then' value. *)
-    Block.position_at_end then_bb;
-    lv_then <-- f_lv_then;
-    (* Codegen of 'then' can change the current block, update then_bb for the
-     * phi. We create a new name because one is used for the phi node, and the
-     * other is used for the conditional branch. *)
-    new_then_bb <-- Block.insertion;
+    (then_bb, lv_then, new_then_bb) <-- append_code_block "then" lv_then;
+    (else_bb, lv_else, new_else_bb) <-- append_code_block "else" lv_else;
 
-    let else_bb = Block.append ~name:"else" the_function in
-    (* Emit 'else' value. *)
-    Block.position_at_end else_bb;
-    lv_else <-- f_lv_else;
-    (* Codegen of 'else' can change the current block, update else_bb for the
-     * phi. We create a new name because one is used for the phi node, and the
-     * other is used for the conditional branch. *)
-    new_else_bb <-- Block.insertion;
-
-    (* Emit merge block. *)
-    let merge_bb = Block.append ~name:"ifcont" the_function in
-    Block.position_at_end merge_bb;
-    let incoming = [(lv_then, new_then_bb); (lv_else, new_else_bb)] in
-    (* Llvm.build_phi returns the merged value, which can be used the
-     return of the entire (if ...) *)
-    phi <-- phi incoming ~name:"iftmp";
+    (* merge_bb and new_merge_bb should be the same *)
+    (merge_bb, phi, new_merge_bb) <-- append_code_block "ifcont" begin
+      let incoming = [(lv_then, new_then_bb); (lv_else, new_else_bb)] in
+      (* Llvm.build_phi returns the merged value, which can be used the
+         return of the entire (if ...) *)
+      phi incoming ~name:"iftmp"
+    end;
 
     (* Return to the start block to add the conditional branch. *)
     Block.position_at_end start_bb;
-    Monad.ignore (cond_br lv_cond then_bb else_bb);
+    cond_br lv_cond then_bb else_bb;
 
     (* Set a unconditional branch at the end of the 'then' block and the
      * 'else' block to the 'merge' block. *)
-    Block.position_at_end new_then_bb;
-    Monad.ignore (br merge_bb);
-
-    Block.position_at_end new_else_bb;
-    Monad.ignore (br merge_bb);
+    uncond_br new_then_bb merge_bb;
+    uncond_br new_else_bb merge_bb;
 
     (* Finally, set the G.builder to the end of the merge block. *)
-    Block.position_at_end merge_bb;
+    Block.position_at_end new_merge_bb;
 
     return phi
 
+  let for_loop 
+      (init : 'a v) (* initialization of the loop variable of type 'a v *)
+      (cond : 'a v -> i1 v m) (* test on the loop variable *)
+      (do_ : 'a v -> 'a v m) (* do the job and update the loop variable *) = perform
+    start_bb <-- Block.insertion;
+    current_function <-- current_function ();
+
+    (phi_enter, phi, phi_exit) <-- append_code_block "phi" (
+      perform
+        let incoming = [(init, start_bb)] in (* do is not prepared. Added later. *)
+        phi incoming ~name:"fortmp");
+
+    (do_enter,   do_,  do_exit)   <-- append_code_block "do" (do_ phi);
+    \ Llvm.add_incoming (!=<do_, do_exit) !=<phi; (* now we can add the other incoming *)
+
+    let exit_bb = Block.append ~name:"exit" current_function in
+
+    (cond_enter, _cond, _cond_exit) <-- append_code_block "cond" (perform
+      cond <-- cond phi;
+      cond_br cond do_enter exit_bb;
+      return cond);
+
+    uncond_br start_bb phi_enter;
+    uncond_br do_exit phi_enter;
+    uncond_br phi_exit cond_enter;
+
+    Block.position_at_end exit_bb;
+
+    return ()
+
   let exec =
     let cntr = ref 0 in
     fun (v : unit m) ->
     val parent : Llvm.llbasicblock -> ('a -> 'b) pointer v
   end
 
-  val func : string -> 'a typ -> 'b Ltype.Base.WithString.ts -> ('b vs -> 'a v m) -> ('b -> 'a) pointer v m
-    (** [func name return_type arg_types f] defines a function of a name [name] whose type is
-        [arg_types] -> [return_type]. Its function body is defined by [f].
-    *)
+  val func : string -> 'a typ -> 'b Ltype.Base.WithString.ts 
+    -> (('b -> 'a) pointer v (* self *)
+        -> 'b vs -> 'a v m) -> ('b -> 'a) pointer v m
+  (** [func name return_type arg_types f] defines a function of a name [name] whose type is
+      [arg_types] -> [return_type]. Its function body is defined by [f].
+      Self is for recursion.
+  *)
 
   val return_void : void v m 
-    (** for functions returning void *)
+  (** for functions returning void *)
+
+  val current_function : unit -> ('a -> 'b) pointer v m
+  (** Returns the current function. If not in a function, raises Not_found *) 
+
+  val append_code_block : 
+    string (* name *)
+    -> 'a v m (* codegen *)
+    -> (Llvm.llbasicblock * 'a v * Llvm.llbasicblock) m
+  (** [append_code_block name vm] appends a basicblock of name [name]
+      using the codegen [vm] in the function being defined currently. 
+      It returns the entering block, the codegen result llvalue, and  
+      the exiting block. *)
 
   val if_then_else : i1 v m -> 'a v m -> 'a v m -> 'a v m
+  (** Not_found is raised if not defined in a function *)
+
+  val for_loop : 
+    'a v (* the init loop value *) 
+    -> ('a v -> i1 v m) (* test on the loop value *)
+    -> ('a v -> 'a v m) (* the loop job + loop value update *)
+    -> unit m
+  (** Not_found is raised if not defined in a function *)
 
   val exec : unit m -> unit
     (** [exec u] creates an anonymous function from [u] and runs it. *)
     | _ -> assert false
   
   let struct_elements (t : 'typs struct_ typ) : 'typs typs = unsafe_of_array (struct_element_types t)
-  let array t (_tag, size) = array_type t size
+  let array_ t (_tag, size) = array_type t size
     
   let pointer = pointer_type
   let element = element_type
     (** may raise Assert_failure *)
 
   val struct_elements : 'args struct_ typ -> 'args typs
-  val array : 'a typ -> 'tag * int -> ('a * 'tag) array typ
+  val array_ : 'a typ -> 'tag * int -> ('a, 'tag) array_ typ
   val pointer : 'a typ -> 'a pointer typ
   val check_pointer : 'a typ -> 'a pointer typ
     (** may raise Assert_failure *)
   
     let unsafe_gep v ints = 
       const_gep v (Array.of_list (List.map i32_of_int ints))
+
+    let offset_of ty indices =
+      (* CR jfuruse: only for 32 bit arch! *)
+      ptrtoint (unsafe_gep (null (Ltype.pointer ty)) indices) Ltype.i32
   end
   
   (* CR: size of is defined here, where value is available *)
          Note that it can take non pointer type. 
          It does NOT create a null pointer for [ty pointer]! *)
     val unsafe_gep : 'a pointer v -> int list -> 'unsafe pointer v
+
+    val offset_of : 'ty typ -> int list -> i32 v (* CR jfuruse: Only for 32bit arch! *)
   end
   
   module Analysis : sig 
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.