Try to build with OCaml 4.08 version (#957)

* Try to build with OCaml 4.08 version

* Add OCaml 4.08 into the CI script

* Try to build with JaneStreet 0.12 libs version

* changes for compilation with core_kernel.v0.12.0

- added dependencies from core_kernel.rope and
  core_kernel.binary_packing
- used `Caml.Filename`, because `temp_file` wasn't exposed in
  `Core_kernel.Filename`
- used `Mmap.V1.map_file` instead of `Bigarray.Genarray.memmap`.
  Althoug it's a temporary change because most likely we'll
  drop the support of 4.04.1, 4.05, 4.06 compilers, and can use
  just `Unix.map_file` instead

there are lot's of warnings that should be fixed, so it's work
in progress

* List.equal doesn't take labeled argument anymore

* merged with master, updated set of compilers

* List.zip now uses Or_unequal_lengths

* cleaned up oasis

* a couple of minor fixes

1) no global build dependency from core_kernel
2) removed Self from Bap_recipe - probably a merge artifact

* everything compiles, lot's of warning though(

* removed polymorphic compare almost everywhere

* fixes few more lost polymorphic compare + warnings

* fixed one more deprecated

* updates testsuite submodule

* revert changes in text-tags

* remove new Format functions from bap_ir

* updated testsuite/bap-veri/

* silenced a couple of warnings

* reworked bap-future applicative interface

* updated bap-future, replaced Caml.ignore to ignore

* added travis 4.09 to travis

* added setup.ml.pre.in to hide warnings of setup.ml

File "oasis/common.setup.ml.in", line 1773, characters 22-40:
Alert deprecated: module Stdlib.Pervasives
Use Stdlib instead.

If you need to stay compatible with OCaml < 4.07, you can use the
stdlib-shims library: https://github.com/ocaml/stdlib-shims
File "setup.ml", line 3467, characters 16-34:
3467 |                 Pervasives.compare o2 o1)
                       ^^^^^^^^^^^^^^^^^^
Alert deprecated: module Stdlib.Pervasives
Use Stdlib instead.

If you need to stay compatible with OCaml < 4.07, you can use the
stdlib-shims library: https://github.com/ocaml/stdlib-shims

Co-authored-by: gitoleg <[email protected]>

Author: 2 people

.travis-ocaml.sh

@@ -73,6 +73,12 @@ install_on_linux () {
     4.07,1.2.2)
         OCAML_VERSION=4.02; OCAML_FULL_VERSION=4.07.0
         ppa=avsm/ocaml42+opam12 ;;
+    4.08,1.2.2)
+        OCAML_VERSION=4.02; OCAML_FULL_VERSION=4.08.0
+        ppa=avsm/ocaml42+opam12 ;;
+    4.09,1.2.2)
+        OCAML_VERSION=4.02; OCAML_FULL_VERSION=4.09.0
+        ppa=avsm/ocaml42+opam12 ;;
     *) echo "Unknown OCAML_VERSION=$OCAML_VERSION OPAM_VERSION=$OPAM_VERSION"
        echo "(An unset OCAML_VERSION used to default to \"latest\", but you must now specify it."
        echo "Try something like \"OCAML_VERSION=3.12\", \"OCAML_VERSION=4.07\", or see README-travis.md at https://github.com/ocaml/ocaml-ci-scripts )"
@@ -150,6 +156,8 @@ install_on_osx () {
     4.05,1.2.2) OCAML_FULL_VERSION=4.05.0; brew install opam ;;
     4.06,1.2.2) OCAML_FULL_VERSION=4.06.1; brew install opam ;;
     4.07,1.2.2) OCAML_FULL_VERSION=4.07.0; OPAM_SWITCH=${OPAM_SWITCH:-system}; brew install ocaml; brew install opam ;;
+    4.08,1.2.2) OCAML_FULL_VERSION=4.08.0; OPAM_SWITCH=${OPAM_SWITCH:-system}; brew install ocaml; brew install opam ;;
+    4.09,1.2.2) OCAML_FULL_VERSION=4.09.0; OPAM_SWITCH=${OPAM_SWITCH:-system}; brew install ocaml; brew install opam ;;
     *) echo "Unknown OCAML_VERSION=$OCAML_VERSION OPAM_VERSION=$OPAM_VERSION"
        exit 1 ;;
   esac

.travis.yml

@@ -37,10 +37,9 @@ cache:
   - $HOME/save_opam
 
 env:
-  - OCAML_VERSION=4.04.1
-  - OCAML_VERSION=4.05
-  - OCAML_VERSION=4.06
   - OCAML_VERSION=4.07 WITH_BUILD_CACHE=true
+  - OCAML_VERSION=4.08
+  - OCAML_VERSION=4.09
 
 stage: Compile
 script: bash -ex .travis_install.sh
@@ -58,4 +57,4 @@ jobs:
   - stage: Unit tests, checks and bil tests
     env:
     - OCAML_VERSION=4.07 WITH_BUILD_CACHE=true
-    script: bash -ex .run_travis_tests.sh veri
+    script: bash -ex .run_travis_tests.sh veri

configure

@@ -52,7 +52,7 @@ fi
 ocaml tools/cat.ml '"\n# $name\n"' -- $SECTIONS $AB _oasis
 ocaml tools/cat.ml '"\n# $name\n"' -- $TAGS _tags.in _tags
 ocaml tools/cat.ml '"\n#1 \"$name\"\n"' -- $PLUGINS myocamlbuild.ml.in myocamlbuild.ml
-ocaml tools/cat.ml '"\n#1 \"$name\"\n"' -- $SETUPS setup.ml.in setup.ml
+ocaml tools/cat.ml '"\n#1 \"$name\"\n"' -- setup.ml.pre.in $SETUPS setup.ml.in setup.ml
 oasis $QUIET setup
 ocamlfind ocamlopt unix.cmxa setup.ml -o setup.exe
 rm setup.cmx setup.cmi setup.o

lib/arm/arm_branch.ml

@@ -18,7 +18,7 @@ let lift operand ?link ?x:_ ?cond addr =
       let width = Word.bitwidth offset in
       let _1 = Word.one 32 in
       let min_32 = Word.Int_exn.(_1 lsl Word.of_int 31 ~width) in
-      let offset = if offset = min_32 then Word.zero 32 else offset in
+      let offset = if Word.equal offset min_32 then Word.zero 32 else offset in
       let r = Word.Int_exn.(addr + pc_offset + offset) in
       Bil.int r in
   (* TODO detect change to thumb in `x` *)

lib/arm/arm_mem.ml

@@ -8,6 +8,8 @@ module Env = Arm_env
 
 (** Memory access operations *)
 
+let is_pc v = Var.equal v Env.pc
+
 
 (* Doug TODO check for misaligned access *)
 (* Single-register memory access *)
@@ -19,27 +21,27 @@ let lift_r  ~(dst1 : Var.t) ?(dst2 : Var.t option) ~(base : Var.t)
    * Use the originals
    **)
   let address = match mode, operation, size, dst1 with
-    | PostIndex, Ld, W, d when d = Env.pc -> Bil.var o_base
-    | PreIndex, Ld, W, d when d = Env.pc  -> Bil.(var o_base + offset)
+    | PostIndex, Ld, W, d when is_pc d -> Bil.var o_base
+    | PreIndex, Ld, W, d when is_pc d  -> Bil.(var o_base + offset)
     | PostIndex, _,  _, _               -> Bil.var base
     | PreIndex, _, _, _ | Offset, _, _, _ -> Bil.(var base + offset) in
 
   (* Create temps for original if this is a jump *)
   let pre_write_back = match mode, operation, size, dst1 with
-    | PreIndex,  Ld, W, d when d = Env.pc -> [
+    | PreIndex,  Ld, W, d when is_pc d -> [
         Bil.move o_base Bil.(var base);
         Bil.move base  Bil.(var base + offset)
       ]
-    | PostIndex, Ld, W, d when d = Env.pc -> [
+    | PostIndex, Ld, W, d when is_pc d -> [
         Bil.move o_base  Bil.(var base);
         Bil.move base Bil.(var base + offset)
       ]
     | Offset, _, _, _ -> []
     | _ -> [] in
 
   let write_back = match mode, operation, size, dst1 with
-    | PreIndex,  Ld, W, d when d = Env.pc -> []
-    | PostIndex, Ld, W, d when d = Env.pc -> []
+    | PreIndex,  Ld, W, d when is_pc d -> []
+    | PostIndex, Ld, W, d when is_pc d -> []
     | Offset,    _,  _, _               -> []
     | _ -> [Bil.move base Bil.(var base + offset)] in
 
@@ -66,7 +68,7 @@ let lift_r  ~(dst1 : Var.t) ?(dst2 : Var.t option) ~(base : Var.t)
       | W | D -> [] in
     let loads =
       let mem = Bil.var (Env.mem) in
-      if size = D then [
+      if [%compare.equal: size] size D then [
         Bil.move dst1 (load mem address);
         Bil.move (uw dst2) (load mem Bil.(address + four));
       ] else [
@@ -82,7 +84,7 @@ let lift_r  ~(dst1 : Var.t) ?(dst2 : Var.t option) ~(base : Var.t)
     (* truncate the value if necessary *)
     let trunc = match size with
       | B | H ->
-        let n = if size = B then 8 else 16 in
+        let n = if [%compare.equal: size] size B then 8 else 16 in
         [Bil.move temp Bil.(cast low n (var dst1))]
       | W | D -> [] in
     let stores =

lib/arm/arm_mem_shift.ml

@@ -22,16 +22,17 @@ let repair_imm (src : word) ~sign_mask ~imm_mask rtype : exp =
   let bit_set =
     Word.(Z.(word sign_mask land src) = word sign_mask) in
   let negate =
-    (bit_set && rtype = `NEG) ||
-    (not bit_set && rtype = `POS) in
+    (bit_set && [%compare.equal: repair] rtype `NEG) ||
+    (not bit_set && [%compare.equal: repair] rtype `POS) in
   let offset = Z.(src land word imm_mask) in
   Bil.int (if negate then Z.neg offset else offset)
 
 let repair_reg reg imm ~sign_mask rtype =
   let bit_set =
     Word.(Z.(word sign_mask land imm) = word sign_mask) in
   let negate =
-    (bit_set && rtype = `NEG) || (not bit_set && rtype = `POS)
+    (bit_set && [%compare.equal: repair] rtype `NEG) ||
+    (not bit_set && [%compare.equal: repair] rtype `POS)
   in
   let m_one = Word.(ones (bitwidth imm))  in
   if negate then Bil.(int m_one * reg) else reg

lib/arm/arm_shift.ml

@@ -93,10 +93,10 @@ let mem_shift ~src shift typ =
   let shift_amt w = Word.Int_err.(!$w land wordm 0xFFF) >>| Bil.int in
   (* Converts the shift to a negative if the negative bit is set *)
   let to_neg w exp =
-    if Word.Int_err.(wordm 0x1000 land !$w = wordm 0x1000) then
-      Bil.(int (Word.ones width) * exp)
-    else
-      exp in
+    match Word.Int_err.(wordm 0x1000 land !$w) with
+    | Ok x when Word.equal x (word 0x1000) ->
+       Bil.(int (Word.ones width) * exp)
+    | _ -> exp in
   let r = shift_typ shift >>= fun t -> shift_amt shift >>= fun amt ->
     return (t,amt) in
   match r with

lib/arm/arm_types.ml

@@ -304,6 +304,7 @@ type mode_r = Offset | PreIndex | PostIndex
 type sign = Signed | Unsigned
 type operation = Ld | St
 type size = B | H | W | D
+[@@deriving compare]
 
 (** Types for multiple-register memory access *)
 type mode_m = IA | IB | DA | DB
@@ -314,7 +315,7 @@ type arth = [`ADD | `ADC | `SBC | `RSC | `SUB | `RSB ]
 type move = [`AND | `BIC | `EOR | `MOV | `MVN | `ORR ]
 type data_oper = [ arth | move]
 
-type repair = [`POS | `NEG]
+type repair = [`POS | `NEG] [@@deriving compare]
 
 (** shift types *)
 type shift = [`ASR | `LSL | `LSR | `ROR | `RRX]

lib/arm/arm_utils.ml

@@ -30,7 +30,7 @@ let tmp ?(name="v") typ =
 
 
 let assn d s =
-  if d = Env.pc then Bil.jmp s else Bil.move d s
+  if Var.equal d Env.pc then Bil.jmp s else Bil.move d s
 
 let bitlen = function
   | Type.Imm len -> len

lib/bap/bap_project.ml

@@ -13,6 +13,7 @@ open Format
 module Driver = Bap_disasm_driver
 
 module Event = Bap_main_event
+module Buffer = Caml.Buffer
 include Bap_self.Create()
 
 let find name = FileUtil.which name
@@ -451,7 +452,7 @@ module Pass = struct
   [@@deriving variants, sexp_of]
 
   let find name : pass option =
-    DList.find passes ~f:(fun p -> p.name = name)
+    DList.find passes ~f:(fun p -> String.equal p.name name)
 
   exception Failed of error [@@deriving sexp]
 
@@ -462,7 +463,7 @@ module Pass = struct
       raise (Failed (Runtime_error (pass, Exn.Reraised (backtrace, exn))))
 
   let is_evaled pass proj =
-    List.exists proj.passes ~f:(fun name -> name = pass.name)
+    List.exists proj.passes ~f:(fun name -> String.equal name pass.name)
 
   let eval pass proj = {
     (pass.main proj) with

lib/bap/bap_self.ml

@@ -6,6 +6,7 @@ open Format
 open Cmdliner
 
 module Event = Bap_main_event
+module Buffer = Caml.Buffer
 
 module Create() = struct
   let bundle = main_bundle ()
@@ -39,7 +40,7 @@ module Create() = struct
     let is_key = String.is_prefix ~prefix:"-" in
     Array.fold (Plugin.argv ()) ~init:([],`drop) ~f:(fun (args,act) arg ->
         let take arg = ("--" ^ arg) :: args in
-        if arg = Sys.argv.(0) then (name::args,`drop)
+        if String.equal arg Sys.argv.(0) then (name::args,`drop)
         else match String.chop_prefix arg ~prefix, act with
           | None,`take when is_key arg -> args,`drop
           | None,`take -> arg::args,`drop
@@ -49,7 +50,7 @@ module Create() = struct
     fst |> List.rev |> Array.of_list
 
   let argv =
-    if name = main then Sys.argv
+    if String.equal name main then Sys.argv
     else filter_args name
 
   let has_var v = match Sys.getenv ("BAP_" ^ String.uppercase v) with

lib/bap_bml/bap_bml.ml

@@ -71,7 +71,7 @@ module Cmp(T : Comparable) = struct
 end
 
 let (-) pref tag = pref ^ "-" ^ Value.Tag.name tag
-let (+) pref suf = if suf = "" then pref else pref^"-"^suf
+let (+) pref suf = if String.is_empty suf then pref else pref^"-"^suf
 
 let unit suf set is tag =
   Mappers.Nullary.register (set-tag+suf) (marker ident tag ());

lib/bap_bundle/bap_bundle.ml

@@ -1,5 +1,7 @@
 open Core_kernel
 
+module Filename = Caml.Filename
+
 module Std = struct
   exception Not_a_bundle
 
@@ -165,7 +167,7 @@ module Std = struct
       b >>> fun zip ->
       Zip.entries zip |> List.filter_map ~f:(fun e ->
           let name = Zip.(e.filename) in
-          Option.some_if (not (name = Nameof.manifest)) name)
+          Option.some_if (not (String.equal name Nameof.manifest)) name)
 
     let transform files bundle ~f =
       let zin = open_in bundle.path in
@@ -223,7 +225,7 @@ module Std = struct
 
     let update_manifest bundle ~f =
       update bundle ~f:(fun file ->
-          if file = Nameof.manifest
+          if String.equal file Nameof.manifest
           then `Map (fun s -> Manifest.(of_string s |> f |> to_string))
           else `Copy)
 

lib/bap_byteweight/bap_byteweight.ml

@@ -45,14 +45,14 @@ module Make
     let rec outer = function
       | 0 -> ()
       | n -> inner n 0
-    and inner length m = match Corpus.look set ~length m with
-      | None -> outer (length - 1)
-      | Some s when pass = `Pos && test s ->
+    and inner length m = match Corpus.look set ~length m,pass with
+      | None,_ -> outer (length - 1)
+      | Some s, `Pos when test s ->
         Trie.change trie s (function
             | None -> Some (1,0)
             | Some (a,b) -> Some (a+1,b));
         inner length (m+1)
-      | Some s when pass = `Neg ->
+      | Some s, `Neg ->
         Trie.change trie s (function
             | Some (m,n) when not(test s) -> Some (m,n+1)
             | x -> x);
@@ -69,7 +69,7 @@ module Make
     | None -> false
     | Some (_,(a,b)) ->
       let n = a + b in
-      Float.(of_int a / of_int n) > threshold
+      Float.(of_int a / of_int n > threshold)
 
   let next_if (trie : t) ~length ~f set n =
     let open Option.Monad_infix in
@@ -87,7 +87,7 @@ module Make
   let next trie ~length ~threshold set n =
     next_if trie ~length set n ~f:(fun _ _ (a,b) ->
         let n = a + b in
-        Float.(of_int a / of_int n) > threshold)
+        Float.(of_int a / of_int n > threshold))
 
   let length = Trie.length
 end

lib/bap_byteweight/bap_byteweight_signatures.ml

@@ -64,7 +64,7 @@ let save_exn ?comp ~mode ~path arch data =
     let dst = entry ?comp ~mode arch in
     List.iter old ~f:(fun (entry,data) ->
         let file = Zip.(entry.filename) in
-        if file <> dst then Zip.add_entry data zip file);
+        if String.(file <> dst) then Zip.add_entry data zip file);
     Zip.add_entry data zip dst;
     Zip.close_out zip
   with Sys_error msg -> fail (`Sys_error msg)

lib/bap_c/bap_c_abi.ml

@@ -86,7 +86,7 @@ let create_arg i addr_size intent name t (data,exp) sub =
   let typ = match data with
     | Bap_c_data.Imm (sz,_) -> Type.Imm (Size.in_bits sz)
     | _ -> Type.Imm (Size.in_bits addr_size) in
-  let name = if name = "" then sprintf "arg%d" (i+1) else name in
+  let name = if String.is_empty name then sprintf "arg%d" (i+1) else name in
   let var = Var.create (Sub.name sub ^ "_" ^ name) typ in
   let arg = Arg.create ~intent var exp in
   let arg = Term.set_attr arg Attrs.data data in
@@ -96,22 +96,24 @@ let create_arg i addr_size intent name t (data,exp) sub =
 
 
 let find_by_name prog name =
-  Term.enum sub_t prog |> Seq.find ~f:(fun sub -> Sub.name sub = name)
+  Term.enum sub_t prog |> Seq.find ~f:(fun sub -> String.equal (Sub.name sub) name)
 
 let find_first_caller prog tid =
   Term.enum sub_t prog |> Seq.find ~f:(fun sub ->
       Term.enum blk_t sub |> Seq.exists ~f:(fun blk ->
           Term.enum jmp_t blk |> Seq.exists ~f:(fun jmp ->
               match Jmp.kind jmp with
-              | Call c -> Call.target c = Direct tid
+              | Call c -> Label.equal (Call.target c) (Direct tid)
               | _ -> false)))
 
 let proj_int = function Bil.Int x -> Some x | _ -> None
 
-let has_libc_runtime prog =
-  find_by_name prog "__libc_csu_fini" <> None &&
-  find_by_name prog "__libc_csu_init" <> None
+let is_sub_exists prog name = Option.is_some @@ find_by_name prog name
+let is_sub_absent prog name = not (is_sub_exists prog name)
 
+let has_libc_runtime prog =
+  is_sub_exists prog "__libc_csu_fini" &&
+  is_sub_exists prog "__libc_csu_init"
 
 let find_entry_point prog =
   Term.enum sub_t prog |>
@@ -156,7 +158,7 @@ let rename_main abi prog = match detect_main_address prog with
         | _ -> sub)
 
 let rename_libc_start_main abi prog =
-  if find_by_name prog "__libc_start_main" = None
+  if is_sub_absent prog "__libc_start_main"
   then match find_libc_start_main prog with
     | None -> prog
     | Some tid ->
@@ -174,8 +176,8 @@ let stage2 stage1 = object
   method! run prog =
     let prog = stage1#run prog in
     if has_libc_runtime prog &&
-       (find_by_name prog "main" = None ||
-        (find_by_name prog "__libc_start_main" = None))
+        (is_sub_absent prog "main" ||
+        (is_sub_absent prog "__libc_start_main"))
     then fix_libc_runtime stage1 prog
     else prog
 end

lib/bap_c/bap_c_attr.ml

@@ -19,7 +19,7 @@ let apply attr sub =
 module Gnu = struct
   let register_attr n f =
     let pass {Attr.name; args} sub =
-      if n = name then f args sub else sub in
+      if String.equal n name then f args sub else sub in
     register pass
 
   exception Attr_type   of string * string

lib/bap_c/bap_c_size.ml

@@ -69,7 +69,7 @@ class base (m : model) = object(self)
     | `Structure {Spec.t={Compound.fields}}
     | `Union {Spec.t={Compound.fields}} ->
       List.fold fields ~init:byte ~f:(fun align (_,t) ->
-          max align (self#alignment t))
+          Size.max align (self#alignment t))
     | `Function _ -> (self#pointer :> size)
     | #scalar as t -> self#scalar t