Test for LLVM atomics from OCaml through C

test_atomics.ml

open Llvm
open Llvm_bitwriter

let _ =
  let c = global_context () in
  let m = create_module c "mod" in
  let b = builder c in
  let i32_t = i32_type c in
  let ptr_t = pointer_type i32_t in

  let ft = function_type i32_t [| ptr_t; i32_t |] in
  let f = declare_function "fffuuu" ft m in

  let bb = append_block c "entry" f in
  position_at_end bb b;

  let ptr = param f 0 in
  let i = param f 1 in
    
  let ops =[AtomicRMWOp.Xchg;
            AtomicRMWOp.Add;
            AtomicRMWOp.Sub;
            AtomicRMWOp.And;
            (* AtomicRMWOp.Nand; *) (* not supported by NVPTX *)
            AtomicRMWOp.Or;
            AtomicRMWOp.Xor;
            AtomicRMWOp.Max;
            AtomicRMWOp.Min;
            AtomicRMWOp.UMax;
            AtomicRMWOp.UMin] in

  let orders = [(* AtomicOrdering.NotAtomic; *)
                (* AtomicOrdering.Unordered; *)
                (* AtomicOrdering.Consume; *)
                AtomicOrdering.Acquire;
                AtomicOrdering.Release;
                AtomicOrdering.AcquireRelease;
                AtomicOrdering.SequentiallyConsistent] in
  
  let cartesian aa bb =
    (List.concat
      (List.map
        (fun a ->
          List.map
            (fun b -> (a,b))
            bb)
        aa))
  in
  
  let x =
    List.fold_left
      (fun x (op,order) -> build_atomicrmw op ptr x order b)
      i
      (cartesian ops orders)
  in
  
  let x =
    List.fold_left
      (fun x order -> build_cmpxchg ptr i x order b)
      x
      orders
  in
  
  ignore (build_ret x b);

  Llvm_analysis.assert_valid_function f;

  if write_bitcode_file m "test_llvm_atom.bc" then
    ignore (Printf.printf "yes\n")
  else
    ignore (Printf.printf "no\n")