Fix compatibility with new versions of OCaml by the use of OByteLib a…

…s frontend/backend.

VERSION

@@ -1 +1 @@
-2.2
+2.3

configure

@@ -76,10 +76,10 @@ done
 echo -n "\
 BINDIR = $BINDIR
 MAN1DIR = $MANDIR/man1
-OCAMLC = $OCAMLC -w Ae -warn-error A -safe-string -strict-formats -strict-sequence
-OCAMLOPT = $OCAMLOPT -w Ae -warn-error A -safe-string -strict-formats -strict-sequence
+OCAMLC = $OCAMLC -w @a-4-70 -warn-error A -safe-string -strict-formats -strict-sequence
+OCAMLOPT = $OCAMLOPT -w @a-4-70 -warn-error A -safe-string -strict-formats -strict-sequence
 OCAMLC_UNSAFE = $OCAMLC
-OCAMLBUILD = $OCAMLBUILD -cflags -w,Ae,-warn-error,A,-safe-string,-strict-formats,-strict-sequence -lflags -w,Ae,-warn-error,A,-safe-string,-strict-formats,-strict-sequence -no-links -classic-display
+OCAMLBUILD = $OCAMLBUILD -cflags -w,@a-4-70,-warn-error,A,-safe-string,-strict-formats,-strict-sequence -lflags -w,@a-4-70,-warn-error,A,-safe-string,-strict-formats,-strict-sequence -no-links -classic-display
 BIN = $PWD/bin
 ETC = $PWD/etc
 DIST = $PWD/dist

src/Makefile

@@ -21,7 +21,7 @@ $(TARG): _build/$(BUILD)
 	cp $< $@
 
 _build/$(BUILD): $(SRCS) config.ml
-	$(OCAMLBUILD) -cflag -g $(BUILD)
+	$(OCAMLBUILD) -cflags -I,+../obytelib,-g -lflags -I,+../obytelib,obytelib.cmxa $(BUILD)
 
 config.ml: $(ETC)/config.ml
 	cp $< $@

src/cleanbra.ml

@@ -9,16 +9,13 @@
 (*                                                                       *)
 (*************************************************************************)
 
-open Instr
+open OByteLib.Normalised_instr
 
 let clean code =
   let f i bc =
     match bc with
-      | Branch ptr | Branchif ptr | Branchifnot ptr | Beq (_, ptr)
-      | Bneq (_, ptr) | Blint (_, ptr) | Bleint (_, ptr) | Bgtint (_, ptr)
-      | Bgeint (_, ptr) | Bultint (_, ptr) | Bugeint (_, ptr) ->
-        if ptr.instr_ind = i + 1 then
-          code.(i) <- Nop
+      | BRANCH ptr | BRANCHIF ptr | BRANCHIFNOT ptr | COMPBRANCH (_, _, ptr) ->
+        if ptr = i + 1 then code.(i) <- Step1.nop;
       | _ -> ()
   in
   Array.iteri f code;

src/cleanenvs.ml

@@ -9,36 +9,15 @@
 (*                                                                       *)
 (*************************************************************************)
 
-open Instr;;
+open OByteLib.Normalised_instr
 
 type mark = Unused | Valid | Invalid
 
 let compute_nexts code =
   let f i bc =
     match bc with
-      | Branch ptr ->
-        [ ptr.instr_ind ]
-
-      | Branchif ptr | Branchifnot ptr | Beq (_, ptr) | Bneq (_, ptr)
-      | Blint (_, ptr) | Bleint (_, ptr) | Bgtint (_, ptr) | Bgeint (_, ptr)
-      | Bultint (_, ptr) | Bugeint (_, ptr) | Pushretaddr ptr | Pushtrap ptr ->
-        [ succ i ; ptr.instr_ind ]
-
-      | Switch (_, tab) ->
-        Array.to_list (Array.map (fun ptr -> ptr.instr_ind) tab)
-
-      | Grab _ ->
-        [ pred i ; succ i ]
-
-      | Return _ | Appterm (_, _) | Raise | Reraise | Raisenotrace | Stop ->
-        []
-
-      | Apply n when n > 3 ->
-        []
-
-      | _ ->
-        [ succ i ]
-  in
+    | APPLY n when n > 3 -> []
+    | instr -> get_nexts i instr in
   Array.mapi f code
 ;;
 
@@ -74,59 +53,58 @@ let replace_envaccs code data =
   let ptr_map = Array.make nb_instr (-1) in
   let new_globals = ref [] in
   let global_ind = ref (Array.length data) in
-  let alloc_global ptr ptrs env_ind =
+  let alloc_global ptrs env_ind =
     let glob_ind = !global_ind in
     let ptrs_nb = Array.length ptrs in
     let update_env_assoc env_ofs fun_ptr =
       let env_assoc =
-        try List.assoc fun_ptr.instr_ind !new_globals with Not_found ->
+        try List.assoc fun_ptr !new_globals with Not_found ->
           let new_env_assoc = ref [] in
-          new_globals := (fun_ptr.instr_ind, new_env_assoc) :: !new_globals;
+          new_globals := (fun_ptr, new_env_assoc) :: !new_globals;
           new_env_assoc
       in
       env_assoc :=
         (env_ind + 2 * (ptrs_nb - env_ofs - 1), glob_ind) :: !env_assoc;
     in
-    update_env_assoc (-1) ptr;
     Array.iteri update_env_assoc ptrs;
     incr global_ind;
     glob_ind
   in
-  let setglobals_of_closure env_size ptr ptrs new_closure =
+  let setglobals_of_closure env_size ptrs new_closure =
     let rec f i =
       if i > env_size then [ new_closure ] else
-        let glob_ind = alloc_global ptr ptrs i in
-        Acc 0 :: Setglobal glob_ind :: Pop 1 :: f (i + 1)
+        let glob_ind = alloc_global ptrs i in
+        ACC 0 :: SETGLOBAL glob_ind :: POP 1 :: f (i + 1)
     in
-    let glob_ind = alloc_global ptr ptrs 1 in
-    Setglobal glob_ind :: f 2
+    let glob_ind = alloc_global ptrs 1 in
+    SETGLOBAL glob_ind :: f 2
   in
   let rec gen_new_code i j acc =
     if i = nb_instr then Array.of_list (List.rev acc) else (
       ptr_map.(i) <- j;
       match ((marks.(i) = Valid), code.(i)) with
-        | (true, Closure (env_size, ptr)) when env_size > 0 ->
-          let new_closure = Closure (0, ptr) in
-          let instrs =  setglobals_of_closure env_size ptr [||] new_closure in
+        | (true, CLOSURE (env_size, ptr)) when env_size > 0 ->
+          let new_closure = CLOSURE (0, ptr) in
+          let instrs =  setglobals_of_closure env_size [| ptr |] new_closure in
           gen_new_code (i + 1) (j + List.length instrs) (List.rev instrs @ acc)
-        | (true, Closurerec (fun_nb, env_size, ptr, ptrs)) when env_size > 0 ->
-          let new_closure = Closurerec (fun_nb, 0, ptr, ptrs) in
-          let instrs = setglobals_of_closure env_size ptr ptrs new_closure in
+        | (true, CLOSUREREC (env_size, ptrs)) when env_size > 0 ->
+          let new_closure = CLOSUREREC (0, ptrs) in
+          let instrs = setglobals_of_closure env_size ptrs new_closure in
           gen_new_code (i + 1) (j + List.length instrs) (List.rev instrs @ acc)
         | _ ->
           gen_new_code (i + 1) (j + 1) (code.(i) :: acc)
     )
   in
   let new_code = gen_new_code 0 0 [] in
-  Step1.remap_code new_code ptr_map;
+  let new_code = Step1.remap_code ptr_map new_code in
   let new_nexts = compute_nexts new_code in
   let remap_coverage = Array.make (Array.length new_code) false in
   let remap_envaccs (fun_ind, env_assoc) =
     let rec f i =
       if not remap_coverage.(i) then (
         remap_coverage.(i) <- true;
         begin match new_code.(i) with
-          | Envacc n -> new_code.(i) <- Getglobal (List.assoc n !env_assoc)
+          | ENVACC n -> new_code.(i) <- GETGLOBAL (List.assoc n !env_assoc)
           | _ -> ()
         end;
         List.iter f new_nexts.(i)
@@ -150,9 +128,9 @@ let factor_globals code data nexts =
   let rec compute_orig instr_ind pos =
     if marks.(instr_ind) <> Valid then None else
       match (code.(instr_ind), accus.(instr_ind), stacks.(instr_ind)) with
-        | (Push, [accu_dep], _) ->
+        | (PUSH, [ accu_dep ], _) ->
           compute_orig accu_dep 0
-        | (Acc n, _, stack_deps) -> (
+        | (ACC n, _, stack_deps) -> (
           match stack_deps.(n) with
             | [ instr_ind' ] ->
               compute_orig instr_ind' (stack_sizes.(instr_ind) - n)
@@ -165,11 +143,11 @@ let factor_globals code data nexts =
   let compute_deps instr_ind bc =
     if marks.(instr_ind) = Valid then
       match (bc, accus.(instr_ind)) with
-        | (Setglobal glob_ind, [accu_dep]) when data.(glob_ind) = Obj.repr 0 ->
+        | (SETGLOBAL glob_ind, [accu_dep]) when data.(glob_ind) = Obj.repr 0 ->
           begin match compute_orig accu_dep 0 with
             | Some (dep_ind, pos) ->
               deps.(dep_ind) <- (pos, glob_ind) :: deps.(dep_ind);
-              code.(instr_ind) <- Const 0;
+              code.(instr_ind) <- CONSTINT 0;
             | None ->
               ();
           end;
@@ -195,28 +173,28 @@ let factor_globals code data nexts =
       else
         let assoc = List.sort compare assoc in
         let gen_rev_instrs acc (pos, glob_ind) =
-          if pos = 0 then Setglobal glob_ind :: acc
+          if pos = 0 then SETGLOBAL glob_ind :: acc
           else
             let stack_ind =
               match nexts.(i) with
                 | [] -> assert false
                 | next_ind :: _ -> stack_sizes.(next_ind) - pos + 1
             in
-            Setglobal glob_ind :: Acc stack_ind :: acc
+            SETGLOBAL glob_ind :: ACC stack_ind :: acc
         in
         let rev_instrs =
-          Pop 1 :: Acc 0 ::
-            List.fold_left gen_rev_instrs [ Push; code.(i) ] assoc
+          POP 1 :: ACC 0 ::
+            List.fold_left gen_rev_instrs [ PUSH; code.(i) ] assoc
         in
         let instr_nb = List.length rev_instrs in
         let new_pra_ofs =
           match code.(i) with
-            | Apply n when n >= 4 ->
+            | APPLY n when n >= 4 ->
               begin match stacks.(i).(n) with
                 | [] -> pra_ofs
                 | pushretaddr_ind :: _ ->
                   match code.(pushretaddr_ind) with
-                    | Pushretaddr ptr -> (ptr, instr_nb - 1) :: pra_ofs
+                    | PUSH_RETADDR _ -> (pushretaddr_ind, instr_nb - 1) :: pra_ofs
                     | _ -> assert false
               end;
             | _ -> pra_ofs
@@ -225,17 +203,18 @@ let factor_globals code data nexts =
     )
   in
   let (pra_ofs, new_code) = gen_new_code 0 0 [] [] in
-  Step1.remap_code new_code ptr_map;
-  List.iter (fun (ptr, ofs) -> ptr.instr_ind <- ptr.instr_ind - ofs) pra_ofs;
+  let new_code = Step1.remap_code ptr_map new_code in
+  List.iter (fun (pushretaddr_ind, ofs) ->
+    let i = ptr_map.(pushretaddr_ind) in
+    match new_code.(i) with
+    | PUSH_RETADDR ptr -> new_code.(i) <- PUSH_RETADDR (ptr - ofs)
+    | _ -> assert false
+  ) pra_ofs;
   (***)
   let remap_getglobals instr_ind bc =
     match bc with
-      | Getglobal n ->
-        new_code.(instr_ind) <- Getglobal data_map.(n);
-      | Getglobalfield (n, p) ->
-        new_code.(instr_ind) <- Getglobalfield (data_map.(n), p);
-      | _ ->
-        ();
+      | GETGLOBAL n -> new_code.(instr_ind) <- GETGLOBAL data_map.(n)
+      | _ -> ()
   in
   Array.iteri remap_getglobals new_code;
   (***)