X-Git-Url: http://plrg.eecs.uci.edu/git/?a=blobdiff_plain;f=test%2FBindings%2FOcaml%2Fvmcore.ml;h=637ef3532c54323779ceaa08f82b66f6ecee14aa;hb=1d21395f4ce152e7bf14d9ba6ea23549de6badd4;hp=457e7664efae35225723192debe0a4213721e056;hpb=cc0928ff22d9f3e8f2930874f6727db8c700ec35;p=oota-llvm.git

diff --git a/test/Bindings/Ocaml/vmcore.ml b/test/Bindings/Ocaml/vmcore.ml
index 457e7664efa..637ef3532c5 100644
--- a/test/Bindings/Ocaml/vmcore.ml
+++ b/test/Bindings/Ocaml/vmcore.ml
@@ -34,6 +34,7 @@ let suite name f =
 
 let filename = Sys.argv.(1)
 let m = create_module filename
+let mp = ModuleProvider.create m
 
 
 (*===-- Target ------------------------------------------------------------===*)
@@ -211,12 +212,18 @@ let test_constants () =
   ignore (define_global "Const05" c m);
   insist ((array_type i8_type 9) = type_of c);
 
-  (* RUN: grep {Const06.*3.1459} < %t.ll
+  (* RUN: grep {ConstSingle.*2.75} < %t.ll
+   * RUN: grep {ConstDouble.*3.1459} < %t.ll
    *)
-  group "real";
-  let c = const_float double_type 3.1459 in
-  ignore (define_global "Const06" c m);
-  insist (double_type = type_of c);
+  begin group "real";
+    let cs = const_float float_type 2.75 in
+    ignore (define_global "ConstSingle" cs m);
+    insist (float_type = type_of cs);
+    
+    let cd = const_float double_type 3.1459 in
+    ignore (define_global "ConstDouble" cd m);
+    insist (double_type = type_of cd)
+  end;
   
   let one = const_int i16_type 1 in
   let two = const_int i16_type 2 in
@@ -460,7 +467,33 @@ let test_global_variables () =
   let g = define_global "ConstGlobalVar" fourty_two32 m in
   insist (not (is_global_constant g));
   set_global_constant true g;
-  insist (is_global_constant g)
+  insist (is_global_constant g);
+  
+  begin group "iteration";
+    let m = create_module "temp" in
+    
+    insist (At_end m = global_begin m);
+    insist (At_start m = global_end m);
+    
+    let g1 = declare_global i32_type "One" m in
+    let g2 = declare_global i32_type "Two" m in
+    
+    insist (Before g1 = global_begin m);
+    insist (Before g2 = global_succ g1);
+    insist (At_end m = global_succ g2);
+    
+    insist (After g2 = global_end m);
+    insist (After g1 = global_pred g2);
+    insist (At_start m = global_pred g1);
+    
+    let lf s x = s ^ "->" ^ value_name x in
+    insist ("->One->Two" = fold_left_globals lf "" m);
+    
+    let rf x s = value_name x ^ "<-" ^ s in
+    insist ("One<-Two<-" = fold_right_globals rf m "");
+    
+    dispose_module m
+  end
 
 
 (*===-- Functions ---------------------------------------------------------===*)
@@ -471,17 +504,19 @@ let test_functions () =
   
   (* RUN: grep {declare i32 @Fn1\(i32, i64\)} < %t.ll
    *)
-  group "declare";
-  insist (None = lookup_function "Fn1" m);
-  let fn = declare_function "Fn1" ty m in
-  insist (pointer_type ty = type_of fn);
-  insist (is_declaration fn);
-  insist (0 = Array.length (basic_blocks fn));
-  insist (pointer_type ty2 == type_of (declare_function "Fn1" ty2 m));
-  insist (fn == declare_function "Fn1" ty m);
-  insist (None <> lookup_function "Fn1" m);
-  insist (match lookup_function "Fn1" m with Some x -> x = fn
-                                           | None -> false);
+  begin group "declare";
+    insist (None = lookup_function "Fn1" m);
+    let fn = declare_function "Fn1" ty m in
+    insist (pointer_type ty = type_of fn);
+    insist (is_declaration fn);
+    insist (0 = Array.length (basic_blocks fn));
+    insist (pointer_type ty2 == type_of (declare_function "Fn1" ty2 m));
+    insist (fn == declare_function "Fn1" ty m);
+    insist (None <> lookup_function "Fn1" m);
+    insist (match lookup_function "Fn1" m with Some x -> x = fn
+                                             | None -> false);
+    insist (m == global_parent fn)
+  end;
   
   (* RUN: grep -v {Fn2} < %t.ll
    *)
@@ -531,6 +566,68 @@ let test_functions () =
     insist (None = collector fn);
     set_collector (Some "shadowstack") fn;
     ignore (build_unreachable (builder_at_end (entry_block fn)));
+  end;
+  
+  begin group "iteration";
+    let m = create_module "temp" in
+    
+    insist (At_end m = function_begin m);
+    insist (At_start m = function_end m);
+    
+    let f1 = define_function "One" ty m in
+    let f2 = define_function "Two" ty m in
+    
+    insist (Before f1 = function_begin m);
+    insist (Before f2 = function_succ f1);
+    insist (At_end m = function_succ f2);
+    
+    insist (After f2 = function_end m);
+    insist (After f1 = function_pred f2);
+    insist (At_start m = function_pred f1);
+    
+    let lf s x = s ^ "->" ^ value_name x in
+    insist ("->One->Two" = fold_left_functions lf "" m);
+    
+    let rf x s = value_name x ^ "<-" ^ s in
+    insist ("One<-Two<-" = fold_right_functions rf m "");
+    
+    dispose_module m
+  end
+
+
+(*===-- Params ------------------------------------------------------------===*)
+
+let test_params () =
+  begin group "iteration";
+    let m = create_module "temp" in
+    
+    let vf = define_function "void" (function_type void_type [| |]) m in
+    
+    insist (At_end vf = param_begin vf);
+    insist (At_start vf = param_end vf);
+    
+    let ty = function_type void_type [| i32_type; i32_type |] in
+    let f = define_function "f" ty m in
+    let p1 = param f 0 in
+    let p2 = param f 1 in
+    set_value_name "One" p1;
+    set_value_name "Two" p2;
+    
+    insist (Before p1 = param_begin f);
+    insist (Before p2 = param_succ p1);
+    insist (At_end f = param_succ p2);
+    
+    insist (After p2 = param_end f);
+    insist (After p1 = param_pred p2);
+    insist (At_start f = param_pred p1);
+    
+    let lf s x = s ^ "->" ^ value_name x in
+    insist ("->One->Two" = fold_left_params lf "" f);
+    
+    let rf x s = value_name x ^ "<-" ^ s in
+    insist ("One<-Two<-" = fold_right_params rf f "");
+    
+    dispose_module m
   end
 
 
@@ -578,7 +675,68 @@ let test_basic_blocks () =
   ignore (build_unreachable (builder_at_end bb));
   insist (bb = block_of_value (value_of_block bb));
   insist (value_is_block (value_of_block bb));
-  insist (not (value_is_block (const_null i32_type)))
+  insist (not (value_is_block (const_null i32_type)));
+  
+  begin group "iteration";
+    let m = create_module "temp" in
+    let f = declare_function "Temp" (function_type i32_type [| |]) m in
+    
+    insist (At_end f = block_begin f);
+    insist (At_start f = block_end f);
+    
+    let b1 = append_block "One" f in
+    let b2 = append_block "Two" f in
+    
+    insist (Before b1 = block_begin f);
+    insist (Before b2 = block_succ b1);
+    insist (At_end f = block_succ b2);
+    
+    insist (After b2 = block_end f);
+    insist (After b1 = block_pred b2);
+    insist (At_start f = block_pred b1);
+    
+    let lf s x = s ^ "->" ^ value_name (value_of_block x) in
+    insist ("->One->Two" = fold_left_blocks lf "" f);
+    
+    let rf x s = value_name (value_of_block x) ^ "<-" ^ s in
+    insist ("One<-Two<-" = fold_right_blocks rf f "");
+    
+    dispose_module m
+  end
+
+
+(*===-- Instructions ------------------------------------------------------===*)
+
+let test_instructions () =
+  begin group "iteration";
+    let m = create_module "temp" in
+    let fty = function_type void_type [| i32_type; i32_type |] in
+    let f = define_function "f" fty m in
+    let bb = entry_block f in
+    let b = builder_at (At_end bb) in
+    
+    insist (At_end bb = instr_begin bb);
+    insist (At_start bb = instr_end bb);
+    
+    let i1 = build_add (param f 0) (param f 1) "One" b in
+    let i2 = build_sub (param f 0) (param f 1) "Two" b in
+    
+    insist (Before i1 = instr_begin bb);
+    insist (Before i2 = instr_succ i1);
+    insist (At_end bb = instr_succ i2);
+    
+    insist (After i2 = instr_end bb);
+    insist (After i1 = instr_pred i2);
+    insist (At_start bb = instr_pred i1);
+    
+    let lf s x = s ^ "->" ^ value_name x in
+    insist ("->One->Two" = fold_left_instrs lf "" bb);
+    
+    let rf x s = value_name x ^ "<-" ^ s in
+    insist ("One<-Two<-" = fold_right_instrs rf bb "");
+    
+    dispose_module m
+  end
 
 
 (*===-- Builder -----------------------------------------------------------===*)
@@ -586,6 +744,27 @@ let test_basic_blocks () =
 let test_builder () =
   let (++) x f = f x; x in
   
+  begin group "parent";
+    insist (try
+              ignore (insertion_block (builder ()));
+              false
+            with Not_found ->
+              true);
+    
+    let fty = function_type void_type [| i32_type |] in
+    let fn = define_function "BuilderParent" fty m in
+    let bb = entry_block fn in
+    let b = builder_at_end bb in
+    let p = param fn 0 in
+    let sum = build_add p p "sum" b in
+    ignore (build_ret_void b);
+    
+    insist (fn = block_parent bb);
+    insist (fn = param_parent p);
+    insist (bb = instr_parent sum);
+    insist (bb = insertion_block b)
+  end;
+  
   group "ret void";
   begin
     (* RUN: grep {ret void} < %t.ll
@@ -830,6 +1009,30 @@ let test_module_provider () =
   ModuleProvider.dispose mp
 
 
+(*===-- Pass Managers -----------------------------------------------------===*)
+
+let test_pass_manager () =
+  let (++) x f = ignore (f x); x in
+
+  begin group "module pass manager";
+    ignore (PassManager.create ()
+             ++ PassManager.run_module m
+             ++ PassManager.dispose)
+  end;
+  
+  begin group "function pass manager";
+    let fty = function_type void_type [| |] in
+    let fn = define_function "FunctionPassManager" fty m in
+    ignore (build_ret_void (builder_at_end (entry_block fn)));
+    
+    ignore (PassManager.create_function mp
+             ++ PassManager.initialize
+             ++ PassManager.run_function fn
+             ++ PassManager.finalize
+             ++ PassManager.dispose)
+  end
+
+
 (*===-- Writer ------------------------------------------------------------===*)
 
 let test_writer () =
@@ -841,7 +1044,7 @@ let test_writer () =
   group "writer";
   insist (write_bitcode_file m filename);
   
-  dispose_module m
+  ModuleProvider.dispose mp
 
 
 (*===-- Driver ------------------------------------------------------------===*)
@@ -853,8 +1056,11 @@ let _ =
   suite "global values"    test_global_values;
   suite "global variables" test_global_variables;
   suite "functions"        test_functions;
+  suite "params"           test_params;
   suite "basic blocks"     test_basic_blocks;
+  suite "instructions"     test_instructions;
   suite "builder"          test_builder;
   suite "module provider"  test_module_provider;
-  suite "writer"           test_writer;
+  suite "pass manager"     test_pass_manager;
+  suite "writer"           test_writer; (* Keep this last; it disposes m. *)
   exit !exit_status