Skip to content
This repository
tag: v0.9.4
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 130 lines (115 sloc) 4.474 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
module B = Base
let (<|) f a = f a
let (|>) a f = f a
let ( @* ) g f x = g(f(x))
module O = Ocaml
module G = Grammar
module T = Tools
module L = B.List

module V : Graph.Sig.COMPARABLE with type t = string =
struct
  type t = string
  let equal u v = (u = v)
  let hash = B.Hashtbl.hash
  let compare = Pervasives.compare
end

module Gr = Graph.Imperative.Digraph.ConcreteBidirectional (V)
module SCC = Graph.Components.Make (Gr)

type functions =
  | Normal of string * G.expr list * G.expr list
  | Rec of (string * G.expr list * G.expr list) list

(* DFS to list all the dependicies of a function *)
let rec dfs = function
  | [] -> []
  | G.Errcont name ::tail -> name::dfs tail
  | G.Call (name,_) :: tail -> name::dfs tail
  | G.Upto (_, lst, elst, tout) :: tail
  | G.Fixed (_, lst, elst, tout) :: tail
  | G.Content (_, lst, elst, tout) :: tail
  | G.ReadRaw (lst, elst, tout) :: tail
  | G.Receive (_, _, lst, elst, tout) :: tail ->
      let get_branch = function G.Case (_,x) -> x | _ -> assert false in
        L.concat [
          (L.concat <| L.map (dfs @* get_branch) lst);
          (L.concat <| L.map (dfs @* get_branch) elst);
          (match tout with Some (G.Timeout (_, elst)) -> dfs elst | _ -> [] ) ;
          (dfs tail)
        ]
  | G.Listen (_,_,fn) :: tail -> (L.hd fn)::dfs tail
  | G.Connect (_,fn) :: tail -> (L.hd fn)::dfs tail
  | G.Send _ :: tail -> dfs tail
  | G.Block sub :: tail -> L.append (dfs sub) (dfs tail)
  | G.GMatch (_, _, _, pel) :: tail -> (dfs (L.map (fun (p,e) -> e) pel))@(dfs tail)
  | G.If (_, G.Block a, G.Block b) :: tail -> L.concat [dfs a; dfs b; dfs tail]
  | _ :: tail -> dfs tail

(* Inspired from opalang/opa/reordering.ml : lists the strongly
* connected components of the graph *)
let reorder depslist =
  let graph = Gr.create () in
    L.iter (fun (v0, _) -> Gr.add_vertex graph v0) depslist;
    L.iter (fun (v0, deps) ->
                      StringSet.iter (fun v1->Gr.add_edge graph v0 v1) deps
                   ) depslist;
    SCC.scc_list graph

(* Checks if a function is recursive (or not). *)
let is_recursive name body = L.mem name <| dfs body

let init_table ht lst =
  L.iter (function
             | G.Startfun (n,p,b) -> B.Hashtbl.add ht n (p,b)
             | G.Fun (n,p,b) -> B.Hashtbl.add ht n (p,b)
             | _ -> assert false) lst

(* Given a list of functions, produce a list of function names with their
* respective dependencies *)
let get_dep_list funs lst =
  let get_name = function
    | G.Startfun (n,_,_) | G.Fun (n,_,_) -> n
    | _ -> assert false
  in L.fold_left (fun l f ->
      let v = get_name f in
      let deps =
        if B.Hashtbl.mem funs v then let _,b = B.Hashtbl.find funs v in Some (dfs b)
        else None
      in Option.default_map l (fun d -> (v, StringSet.from_list d)::l) deps
    ) [] lst

let flag_as_rec funs l =
  let get_tuple x = let p,b = B.Hashtbl.find funs x in x,p,b in
  match l with
  | [x] -> (
      try
        let (x,p,b) as t = get_tuple x in
          if is_recursive x b then Rec [t]
          else Normal (x,p,b)
      with Not_found -> failwith <| "Undefined state : " ^ x
    )
  | lst -> Rec (
      L.map (fun x -> try get_tuple x
                with Not_found -> failwith <| "Undefined state : " ^ x)
        lst
    )

(* Reorder functions and resolve cycles (by inserting recursion where needed) *)
let do_it lst =
  let funs = B.Hashtbl.create <| L.length lst in
  let () = init_table funs lst in
  let deps_list = get_dep_list funs lst in
  let ccl = reorder deps_list in
    (* Tag functions as normal or [mutually-]recursive *)
    try
      L.map (flag_as_rec funs) ccl
    with Failure e ->
      let lst =
        B.Hashtbl.fold (fun name _ acc -> acc ^ "\n* " ^ name) funs
          "Here is a list of all defined states :"
      in failwith <| e ^ "\n" ^ lst
Something went wrong with that request. Please try again.