OCaml typechecker AVL Log postprocessing

.gitignore

_build/

dune

(executable
 (public_name tarbre_log)
 (name main)
 (libraries angstrom containers fmt unix))

dune-project

(lang dune 2.8)
(name tarbre_log)

main.ml

type id = int

type op =
  | Read of {
      op : string;
      input : id;
      args : string;
    } 
  | Write of {
      op : string;
      input : id;
      args : string;
      output : id;
      size : int;
    }
  | Free of id

let pp oc (op:op) = match op with
  | Free id ->
    Printf.fprintf oc "free(%i)\n" id
  | Read { op; input; args } ->
    Printf.fprintf oc "%s(%i,%s)\n" op input args 
  | Write { op; input; args; output; size } ->
    Printf.fprintf oc "%s(%i,%s) = %i[%i]\n" op input args output size

let pp_file oc (filename, l) =
  Printf.fprintf oc "New file %s\n" filename;
  List.iter (pp oc) l

let instru_fail =
  let open Angstrom in
  let* id = pos in
  let* peek = peek_string 30 in
  fail @@ Fmt.str "Failed at pos %i with lookahead %S" id peek

let parse_line =
  let open Angstrom in
  let well_paren =
    fix @@ fun well_paren ->
    char '(' *>
    (consumed @@ many
       (take_while1 (function '('|')' -> false | _ -> true) <|> well_paren))
    <* char ')'
  in    
  let+ op = take_till (Char.equal '(') <?> "op"
  and+ all_args = well_paren <?> "args"
  and+ out =
    let int_parser =
      int_of_string <$>
      take_while1 (function '0'..'9' -> true | _ -> false)
    in
    let parser =
      let+ _ = string " = "
      and+ id = int_parser <?> "output id"
      and+ size = char '[' *> int_parser <* char ']' <?> "size"
      in
      Some (id, size)
    in      
    option None parser <?> "output"
  and+ () = end_of_line
  in
  match String.split_on_char ',' all_args with
  | [] -> failwith "Wrong number of args"
  | input::args ->
    let input = try int_of_string input with _ -> failwith input in
    let args = String.concat "," args in
    match out with
    | None ->
      Read {op;input;args}
    | Some (output,size) ->
      Write {op;input;args;output;size}

let parse_log_one_file =
  let open Angstrom in
  let+ _ = string_ci "New File" <* end_of_line <?> "New file"
  and+ lines =
    many_till (parse_line <|> instru_fail)
      (string_ci "Closing File ")
    <?> "Ops"
  and+ file_name =
    take_while (function 'a'..'z'|'A'..'Z'|'.'|'_'|'0'..'9' -> true | _ -> false)
    <* end_of_line
  in
  file_name, lines

let parse = Angstrom.(many1 parse_log_one_file <* (end_of_input  <|> instru_fail) )

module IS = Set.Make(Int)
let fuse_writes l = 
  let rec aux acc live = function
    | Write ({ op = "add"|"addl" ; _ } as w2) ::
      Write ({ op = "add"|"addl" ; _ } as w1) ::
      rest
      when w1.output = w2.input && not (IS.mem w1.output live)
      ->
      aux acc live @@ Write {
        op = "addl"; args = w2.args ^ "," ^ w1.args;
        input=w1.input; output=w2.output;size=w2.size;
      } :: rest
    | (Free input | Read {input;_} as op) :: rest ->
      aux (op :: acc) (IS.add input live) rest
    | Write {input;output;_} as op :: rest ->
      aux (op :: acc) (IS.remove output @@ IS.add input live) rest
    | [] -> List.rev acc
  in
  aux [] IS.empty l
let insert_free l =
  let aux live op =
    let fixup_live input = 
      if not @@ IS.mem input live then
        IS.add input live, [Free input; op]
      else
        live, [op]
    in
    match op with
    | Read {input;_} -> fixup_live input
    | Write {input;output;_} ->
      let live, op = fixup_live input in
      (IS.remove output live), op
    | Free _ -> live, [op]
  in
  snd @@ CCList.fold_flat_map aux IS.empty l
let postprocess ops = 
  List.rev ops
  |> fuse_writes
  |> insert_free
  |> List.rev

let () = 
  let input = Sys.argv.(1) in
  Fmt.pr "Input %s@." input;
  let output = Sys.argv.(2) in
  Fmt.pr "Output %s@." output;
  let oc = open_out output in
  let b =
    Bigarray.array1_of_genarray @@
    Unix.map_file
      (Unix.openfile input [O_RDONLY] 0o777)
      Bigarray.Char
      Bigarray.C_layout
      false (*not shared*)
      [|-1|]
  in
  let l =
    Angstrom.parse_bigstring ~consume:All parse b
  in
  match l with
  | Error s -> Fmt.epr "Failed parsing %s with@,%s@." input s
  | Ok l -> 
    List.iter (fun (file, ops) ->
        Fmt.pr "File %s@." file;
        let ops = postprocess ops in
        let reads, writes =
          CCList.count_true_false
            (function Read _ | Free _ -> true | Write _ -> false) ops
        in
        Fmt.pr "Reads %i, Writes %i@." reads writes;
        pp_file oc (file, ops)
      )
      l

tarbre_log.opam

opam-version: "2.0"
name: "tarbre_log"
maintainer: "Gabriel Radanne <[email protected]>"
synopsis: "Plouf."

build: [
  ["dune" "subst"]{pinned}
  ["dune" "build" "-p" name "-j" jobs]
  ["dune" "runtest" "-p" name "-j" jobs] {with-test}
]

depends: [
  "ocaml" { >= "4.03.0" }
  "dune" {build & >= "1.0"}
  "fmt"
  "containers"
  "angstrom"
]