├── .merlin ├── .gitignore ├── .travis.yml ├── test ├── example.c └── colordot.ml ├── CHANGES.md ├── configure ├── dist.sh ├── Makefile ├── .travis-ci.sh ├── opam ├── LICENSE ├── _oasis ├── README.md ├── setup.ml └── src ├── llvmgraph.mli └── llvmgraph.ml /.merlin: -------------------------------------------------------------------------------- 1 | B _build/src 2 | S src 3 | 4 | PKG llvm 5 | PKG ocamlgraph -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.byte 3 | *.native 4 | lilis.html 5 | setup.data 6 | setup.exe 7 | setup.log -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | script: bash -e .travis-ci.sh 3 | env: 4 | matrix: 5 | - OCAML_VERSION=4.01.0 6 | - OCAML_VERSION=4.02.0 7 | -------------------------------------------------------------------------------- /test/example.c: -------------------------------------------------------------------------------- 1 | int simpleloop (int x, int y) { 2 | while (x < y) { 3 | if (x < 3) 4 | x++; 5 | else 6 | x+=2; 7 | } 8 | return x; 9 | } 10 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | ## dev 4 | 5 | ## 0.2 6 | 7 | Now require llvm>=3.6 8 | 9 | * Bugfix for fold_succ_e 10 | * Restore compat with ocamlgraph 1.8.6 11 | * Add Llvm's uses as label on edges. 12 | 13 | ## 0.1 14 | 15 | * Init ! 16 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /dist.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # dist 4 | # ---- 5 | # Copyright : (c) 2012, Jeremie Dimino 6 | # Licence : BSD3 7 | # 8 | # Script to build the release 9 | 10 | set -e 11 | 12 | # Extract project parameters from _oasis 13 | NAME=`oasis query Name 2> /dev/null` 14 | VERSION=`oasis query Version 2> /dev/null` 15 | PREFIX=$NAME-$VERSION 16 | ARCHIVE=$(pwd)/$PREFIX.tar.gz 17 | 18 | # Clean setup.data and other generated files. 19 | make clean 20 | make distclean 21 | 22 | # Create a branch for the release 23 | git checkout -b release-$VERSION 24 | 25 | # Generate files 26 | oasis setup 27 | 28 | # Remove this script and dev-files 29 | rm -f dist.sh opam .travis-ci.sh .travis.yml 30 | 31 | # Commit 32 | git add --all --force 33 | git commit 34 | git tag $VERSION 35 | 36 | git checkout master 37 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | configure: 37 | $(SETUP) -configure $(CONFIGUREFLAGS) 38 | 39 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 40 | 41 | # OASIS_STOP 42 | -------------------------------------------------------------------------------- /.travis-ci.sh: -------------------------------------------------------------------------------- 1 | PACKAGE=llvmgraph 2 | 3 | case "$OCAML_VERSION" in 4 | 4.01.0) ppa=avsm/ocaml41+opam12 ;; 5 | 4.02.0) ppa=avsm/ocaml42+opam12 ;; 6 | *) echo Unknown $OCAML_VERSION; exit 1 ;; 7 | esac 8 | 9 | echo "yes" | sudo add-apt-repository ppa:$ppa 10 | 11 | echo "yes" | sudo add-apt-repository 'deb http://ppa.launchpad.net/ubuntu-toolchain-r/test/ubuntu precise main' 12 | echo "yes" | sudo add-apt-repository 'deb http://llvm.org/apt/precise/ llvm-toolchain-precise-3.6 main' 13 | wget -O - http://llvm.org/apt/llvm-snapshot.gpg.key | sudo apt-key add - 14 | 15 | sudo apt-get update -qq 16 | sudo apt-get install -qq -y ocaml ocaml-native-compilers camlp4-extra opam llvm-3.6-dev clang-3.6 17 | 18 | export OPAMYES=1 19 | echo OCaml version 20 | ocaml -version 21 | echo OPAM info 22 | opam config report 23 | 24 | opam init 25 | eval `opam config env` 26 | 27 | 28 | opam pin add --verbose -n ${PACKAGE} . 29 | 30 | opam install -t -d --verbose ${PACKAGE} 31 | opam remove --verbose ${PACKAGE} 32 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | name: "llvmgraph" 3 | version: "dev" 4 | author: "Gabriel Radanne " 5 | maintainer: "Gabriel Radanne " 6 | homepage: "https://github.com/Drup/llvmgraph" 7 | bug-reports: "https://github.com/Drup/llvmgraph/issues" 8 | dev-repo: "https://github.com/Drup/llvmgraph.git" 9 | license: "MIT" 10 | tags: [ "llvm" "ocamlgraph" ] 11 | 12 | build: [ 13 | ["ocaml" "setup.ml" "-configure" "--prefix" prefix] 14 | ["ocaml" "setup.ml" "-build"] 15 | ] 16 | build-test: [ 17 | ["ocaml" "setup.ml" "-configure" "--prefix" prefix "--enable-tests"] 18 | ["ocaml" "setup.ml" "-build"] 19 | ["ocaml" "setup.ml" "-test"] 20 | ] 21 | build-doc: ["ocaml" "setup.ml" "-doc"] 22 | 23 | install: ["ocaml" "setup.ml" "-install"] 24 | 25 | remove: ["ocamlfind" "remove" "llvmgraph"] 26 | 27 | available: [ocaml-version >= "4.01.0"] 28 | depends: [ 29 | "ocamlfind" {build} 30 | "llvm" {>= "3.6"} 31 | "ocamlgraph" 32 | # Remove oasis for the package 33 | "oasis" {build} 34 | ] 35 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Gabriel Radanne 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | Name: Llvmgraph 3 | Version: 0.2 4 | Synopsis: Ocamlgraph overlay for llvm 5 | Authors: Gabriel Radanne 6 | License: MIT 7 | Plugins: META (0.3), DevFiles (0.3) 8 | 9 | BuildTools: ocamlbuild 10 | 11 | Library llvmgraph 12 | Path: src 13 | Modules: Llvmgraph 14 | CompiledObject: best 15 | BuildDepends: llvm, ocamlgraph 16 | 17 | 18 | Executable colordot 19 | Install: false 20 | Build$: flag(tests) 21 | Path: test 22 | MainIs: colordot.ml 23 | CompiledObject: best 24 | BuildDepends: llvmgraph, llvm.bitreader, str 25 | 26 | Test colordot 27 | Command: 28 | clang -c -emit-llvm -o example.bc ../test/example.c 29 | $colordot example.bc example.dot 30 | TestTools: colordot 31 | WorkingDirectory: _build 32 | 33 | 34 | AlphaFeatures: ocamlbuild_more_args 35 | Document llvmgraph 36 | Install: false 37 | Type: ocamlbuild (0.3) 38 | BuildTools: ocamldoc 39 | 40 | Title: API reference for Llvmgraph 41 | XOCamlbuildPath: . 42 | XOCamlbuildExtraArgs: 43 | "-docflags '-colorize-code -short-functors -charset utf-8'" 44 | XOCamlbuildLibraries: 45 | llvmgraph -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | llvmgraph [![Build Status](https://travis-ci.org/Drup/llvmgraph.svg?branch=master)](https://travis-ci.org/Drup/llvmgraph) 2 | =============== 3 | 4 | Ocamlgraph overlay for llvm 5 | 6 | The overlay allows you to read and walk (but not write) the control flow graph of an llvm function using the same interface as an ocamlgraph. In particular, read-only ocamlgraph's algorithm can be applied. 7 | 8 | It is also possible to use the Map functor and another graph structure to translate an llvm control flow graph to another graph. 9 | 10 | All Ocamlgraph functors that work on read-only graph have been pre-applied, to ease usage of the library. 11 | 12 | See [the interface](src/llvmgraph.mli) for more details. 13 | 14 | ## Dependencies ## 15 | 16 | - llvm 17 | - ocamlgraph 18 | - str for the [colordot test](test/colordot.ml). 19 | 20 | ## Examples and How-to ## 21 | 22 | The [test](test) folder may be consulted to find some interesting uses of this library. In particular, the [colordot example](test/colordot.ml) is annotated with detailed explanations. 23 | 24 | Here is the result on [`example.c`](test/example.c): 25 | ![colordot.dot](http://i.imgur.com/VahGMoP.png) 26 | 27 | Other examples are very welcome. 28 | -------------------------------------------------------------------------------- /setup.ml: -------------------------------------------------------------------------------- 1 | (* setup.ml generated for the first time by OASIS v0.4.5 *) 2 | 3 | (* OASIS_START *) 4 | (* DO NOT EDIT (digest: 9852805d5c19ca1cb6abefde2dcea323) *) 5 | (******************************************************************************) 6 | (* OASIS: architecture for building OCaml libraries and applications *) 7 | (* *) 8 | (* Copyright (C) 2011-2013, Sylvain Le Gall *) 9 | (* Copyright (C) 2008-2011, OCamlCore SARL *) 10 | (* *) 11 | (* This library is free software; you can redistribute it and/or modify it *) 12 | (* under the terms of the GNU Lesser General Public License as published by *) 13 | (* the Free Software Foundation; either version 2.1 of the License, or (at *) 14 | (* your option) any later version, with the OCaml static compilation *) 15 | (* exception. *) 16 | (* *) 17 | (* This library is distributed in the hope that it will be useful, but *) 18 | (* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *) 19 | (* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *) 20 | (* details. *) 21 | (* *) 22 | (* You should have received a copy of the GNU Lesser General Public License *) 23 | (* along with this library; if not, write to the Free Software Foundation, *) 24 | (* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *) 25 | (******************************************************************************) 26 | 27 | let () = 28 | try 29 | Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH") 30 | with Not_found -> () 31 | ;; 32 | #use "topfind";; 33 | #require "oasis.dynrun";; 34 | open OASISDynRun;; 35 | 36 | (* OASIS_STOP *) 37 | let () = setup ();; 38 | -------------------------------------------------------------------------------- /src/llvmgraph.mli: -------------------------------------------------------------------------------- 1 | (** Read only ocamlgraph interface for the control-flow-graph of llvm functions. *) 2 | 3 | open Graph 4 | 5 | (** Graph of an llvm function. 6 | 7 | Warning : {!map_vertex} is not implemented! *) 8 | module G : sig 9 | include Sig.G 10 | with type t = Llvm.llvalue 11 | and type V.t = Llvm.llbasicblock 12 | and type E.label = Llvm.lluse 13 | 14 | module Ordered_label : Sig.ORDERED_TYPE with type t = E.label 15 | 16 | module Weight : sig 17 | type t = int 18 | type label = E.label 19 | type edge = E.t 20 | val compare : t -> t -> t 21 | val zero : t 22 | val add : t -> t -> t 23 | 24 | (** Constant weight, is always 1. *) 25 | val weight : 'a -> t 26 | end 27 | 28 | end 29 | 30 | (** Mapping from Llvm's control flow graph to another graph. *) 31 | module Map (B : Builder.S) : sig 32 | 33 | val map : 34 | vertex:(G.vertex -> B.G.vertex) -> 35 | label:(G.edge -> B.G.E.label) -> 36 | ?src:(G.E.vertex -> B.G.E.vertex) -> 37 | ?dst:(G.E.vertex -> B.G.E.vertex) -> 38 | G.t -> (G.vertex -> B.G.vertex) * B.G.t 39 | 40 | end 41 | 42 | (** {2 Pre-applied functors} *) 43 | 44 | module Oper : sig 45 | module Choose : module type of Oper.Choose(G) 46 | module Neighbourhood : module type of Oper.Neighbourhood(G) 47 | end 48 | 49 | module Component : module type of Components.Make(G) 50 | 51 | module Path : sig 52 | 53 | module Dijkstra : module type of Path.Dijkstra(G)(G.Weight) 54 | 55 | end 56 | 57 | module Traverse : sig 58 | 59 | module Dfs : module type of Traverse.Dfs(G) 60 | module Bfs : module type of Traverse.Bfs(G) 61 | 62 | end 63 | 64 | module Coloring : module type of Coloring.Make(G) 65 | 66 | module Topological : module type of Topological.Make(G) 67 | 68 | module Kruskal : module type of Kruskal.Make(G)(G.Ordered_label) 69 | 70 | module Prim : module type of Prim.Make(G)(G.Weight) 71 | 72 | module Leaderlist : module type of Leaderlist.Make(G) 73 | 74 | (** Do not compute the Dom graph, it will fail. 75 | Using {!compute_all} is fine, as long as you don't use the dom_graph closure. 76 | *) 77 | module Dominator : 78 | module type of Dominator.Make(struct 79 | include G 80 | let create ?size:_ _ = assert false 81 | let add_edge _ = assert false 82 | end) 83 | -------------------------------------------------------------------------------- /test/colordot.ml: -------------------------------------------------------------------------------- 1 | (* Our goal is to apply the k-coloring algorithm on some llvm control flow graph and to create a dot output correctly colored.*) 2 | 3 | (* First, a bit of prelude. *) 4 | open Llvmgraph 5 | 6 | (* A bit of boilerplate to read a bitcode. *) 7 | let read_bitcode file = 8 | let ctx = Llvm.create_context () in 9 | let mem = Llvm.MemoryBuffer.of_file file in 10 | let m = Llvm_bitreader.parse_bitcode ctx mem in 11 | Llvm.MemoryBuffer.dispose mem ; 12 | m 13 | 14 | (* We will do 3-coloring! Let's define the rgba representations for them. *) 15 | let to_color h v = 16 | match Coloring.H.find h v with 17 | | 0 -> 0x0000FF55l 18 | | 1 -> 0x00FF0055l 19 | | 2 -> 0xFF000055l 20 | | _ -> 0l 21 | 22 | let () = 23 | (* Read the bitcode given in the CLI! *) 24 | let m = read_bitcode Sys.argv.(1) in 25 | 26 | (* Open the file where we will put the dot output! *) 27 | let chout = open_out Sys.argv.(2) in 28 | 29 | (* We 3-colors each functions in the bitcode. *) 30 | Llvm.iter_functions (fun llf -> 31 | (* Coloring is a pre-applied functor defined [module Coloring = Graph.Coloring.Make(G)]. 32 | We use the ocamlgraph implementation directly! 33 | *) 34 | let h = Coloring.coloring llf 3 in 35 | 36 | (* Define a module for dot output using ocamlgraph's Dot functor. *) 37 | let module Dot = Graph.Graphviz.Dot (struct 38 | include G 39 | 40 | (* Boiler-plate for dot definition. *) 41 | let graph_attributes _ = [] 42 | let default_vertex_attributes _ = [] 43 | let get_subgraph _ = None 44 | let default_edge_attributes _ = [] 45 | let edge_attributes e = 46 | let user = Llvm.user (G.E.label e) in 47 | let s = Printf.sprintf "user: %s" (Llvm.string_of_llvalue user) in 48 | [`Label s] 49 | 50 | (* Print the definition of each basic block nicely. *) 51 | let vertex_name v = 52 | (* Fetch a string representation of a basic block. *) 53 | let s = Llvm.(string_of_llvalue (value_of_block v)) in 54 | (* Work around graphviz' crappyness, don't look. *) 55 | Str.global_replace (Str.regexp "\n") "\\l" (Printf.sprintf "\"%s\"" s) 56 | (* Make the output pretty! *) 57 | let vertex_attributes v = [ 58 | `Fontname "monospace"; 59 | `Shape `Record ; 60 | `Style `Filled ; 61 | `FillcolorWithTransparency (to_color h v) ; 62 | ] 63 | 64 | end) 65 | in 66 | 67 | (* Output the dot. *) 68 | Dot.output_graph chout llf 69 | ) m ; 70 | 71 | (* Clean up the mess before leaving. *) 72 | close_out chout 73 | -------------------------------------------------------------------------------- /src/llvmgraph.ml: -------------------------------------------------------------------------------- 1 | open Graph 2 | 3 | let id x = x 4 | 5 | module Misc = struct 6 | 7 | let basicblock_in_function llb llf = 8 | Llvm.block_parent llb = llf 9 | 10 | end 11 | 12 | open Misc 13 | 14 | module G = struct 15 | 16 | (** Raise Invalid_argument if the basic block is not part of the graph. *) 17 | let check_block g b = 18 | if basicblock_in_function b g then () 19 | else raise @@ 20 | Invalid_argument 21 | "Llvmgraph: This basic block doesn't belong to this function." 22 | 23 | 24 | type t = Llvm.llvalue 25 | 26 | module V = struct 27 | type t = Llvm.llbasicblock 28 | 29 | (* COMPARABLE *) 30 | let compare = compare 31 | let hash = Hashtbl.hash 32 | let equal = (==) 33 | 34 | (* LABELED *) 35 | type label = t 36 | let create = id 37 | let label = id 38 | end 39 | 40 | type vertex = V.t 41 | 42 | module E 43 | : Sig.EDGE with type vertex = vertex and type label = Llvm.lluse 44 | = struct 45 | type t = { src : V.t ; use : Llvm.lluse ; dst : V.t } 46 | let compare = compare 47 | 48 | type vertex = V.t 49 | 50 | let src e = e.src 51 | let dst e = e.dst 52 | 53 | type label = Llvm.lluse 54 | let create src use dst = {src ; use ; dst} 55 | let label e = e.use 56 | 57 | end 58 | type edge = E.t 59 | 60 | let is_directed = true 61 | 62 | (** {2 Size functions} *) 63 | 64 | let is_empty x = [||] = Llvm.basic_blocks x 65 | let nb_vertex x = Array.length @@ Llvm.basic_blocks x 66 | 67 | (** We will implement all other primitives though folding on 68 | successor or predecessor edges. *) 69 | 70 | let fold_succ_e f g v z = 71 | check_block g v ; 72 | match Llvm.block_terminator v with 73 | | None -> z 74 | | Some t -> 75 | let n = Llvm.num_operands t in 76 | let rec aux i acc = 77 | if i >= n then acc 78 | else begin 79 | let u = Llvm.operand_use t i in 80 | let o = Llvm.used_value u in 81 | if Llvm.value_is_block o then 82 | let e = E.create v u (Llvm.block_of_value o) in 83 | aux (i+1) @@ f e acc 84 | else aux (i+1) acc 85 | end 86 | in aux 0 z 87 | 88 | let fold_pred_e f g v z = 89 | check_block g v ; 90 | let llv = Llvm.value_of_block v in 91 | let aux acc llu = 92 | let lli = Llvm.user llu in 93 | let llb' = Llvm.instr_parent lli in 94 | if Llvm.is_terminator lli 95 | then f (E.create v llu llb') acc 96 | else acc 97 | in 98 | Llvm.fold_left_uses aux z llv 99 | 100 | 101 | (** {2 Successors and predecessors} *) 102 | 103 | let succ g v = fold_succ_e (fun e l -> E.dst e :: l) g v [] 104 | let pred g v = fold_pred_e (fun e l -> E.src e :: l) g v [] 105 | 106 | let succ_e g v = fold_succ_e (fun e l -> e :: l) g v [] 107 | let pred_e g v = fold_pred_e (fun e l -> e :: l) g v [] 108 | 109 | 110 | (** Degree of a vertex *) 111 | 112 | let out_degree g v = fold_succ_e (fun _ n -> n + 1) g v 0 113 | let in_degree g v = fold_pred_e (fun _ n -> n + 1) g v 0 114 | 115 | (** {2 Membership functions} *) 116 | 117 | let mem_vertex g v = basicblock_in_function v g 118 | 119 | let mem_edge g v1 v2 = 120 | basicblock_in_function v1 g && 121 | List.mem v2 @@ succ g v1 122 | let mem_edge_e g e = mem_edge g (E.src e) (E.dst e) 123 | 124 | (** {2 Graph iterators} *) 125 | 126 | let iter_vertex = Llvm.iter_blocks 127 | 128 | let fold_vertex f g z = 129 | Llvm.fold_left_blocks 130 | (fun g v -> f v g) z g 131 | 132 | (** {2 Edge iterators} *) 133 | 134 | let iter_succ_e f g v = fold_succ_e (fun e () -> f e) g v () 135 | let iter_pred_e f g v = fold_pred_e (fun e () -> f e) g v () 136 | 137 | (** Search functions *) 138 | 139 | exception Found of edge 140 | let find_edge g v1 v2 = 141 | try 142 | iter_succ_e 143 | (fun e -> if V.equal v2 (E.dst e) then raise (Found e)) 144 | g v1 ; 145 | raise Not_found 146 | with Found e -> e 147 | 148 | let find_all_edges g v1 v2 = 149 | fold_succ_e 150 | (fun e l -> if V.equal v2 (E.dst e) then e :: l else l) 151 | g v1 [] 152 | 153 | (** {2 Vertex iterators} *) 154 | 155 | let fold_succ f g v z = fold_succ_e (fun e acc -> f (E.dst e) acc) g v z 156 | let fold_pred f g v z = fold_pred_e (fun e acc -> f (E.src e) acc) g v z 157 | 158 | let iter_succ f g v = fold_succ (fun v () -> f v) g v () 159 | let iter_pred f g v = fold_pred (fun v () -> f v) g v () 160 | 161 | (** {2 Iteration on all edges} *) 162 | (* Implemented by iteration on the successors of each node. *) 163 | 164 | let fold_edges_e f g z = 165 | fold_vertex (fun v acc -> fold_succ_e f g v acc) g z 166 | 167 | let fold_edges f g z = fold_edges_e (fun e acc -> f (E.src e) (E.dst e) acc) g z 168 | 169 | let iter_edges_e f g = fold_edges_e (fun v () -> f v) g () 170 | let iter_edges f g = fold_edges (fun v v' () -> f v v') g () 171 | 172 | let nb_edges g = fold_edges_e (fun _ n -> n + 1) g 0 173 | 174 | 175 | (** Can't implement vertex mapping. *) 176 | let map_vertex f g = failwith "map_vertex: Not implemented" 177 | 178 | module Ordered_label = struct 179 | type t = E.label 180 | let compare (x:t) (y:t) = compare x y 181 | end 182 | 183 | module Weight = struct 184 | type t = int 185 | type label = E.label 186 | type edge = E.t 187 | let compare (x:t) (y:t) = compare x y 188 | let zero = 0 189 | let add = (+) 190 | let weight _ = 1 191 | end 192 | 193 | end 194 | 195 | 196 | module Map (B : Builder.S) = struct 197 | 198 | let map ~vertex ~label ?src ?dst g = 199 | let h = Hashtbl.create 128 in 200 | let get_src = match src with Some f -> f | None -> Hashtbl.find h in 201 | let get_dst = match dst with Some f -> f | None -> Hashtbl.find h in 202 | let f_add_vertex llb new_g = 203 | let v = vertex llb in 204 | Hashtbl.add h llb v ; 205 | B.add_vertex new_g v 206 | in 207 | let f_add_edges e new_g = 208 | let lbl = label e in 209 | let src = G.E.src e in 210 | let dst = G.E.dst e in 211 | B.add_edge_e new_g 212 | (B.G.E.create (get_src src) lbl (get_dst dst)) 213 | in 214 | let new_g = 215 | B.empty () 216 | |> G.fold_vertex f_add_vertex g 217 | |> G.fold_edges_e f_add_edges g 218 | in 219 | Hashtbl.find h, new_g 220 | 221 | end 222 | 223 | (** {2 Some pre-applied functors} *) 224 | 225 | module Oper = struct 226 | module Choose = Oper.Choose(G) 227 | module Neighbourhood = Oper.Neighbourhood(G) 228 | end 229 | 230 | module Component = Components.Make(G) 231 | 232 | module Path = struct 233 | 234 | module Dijkstra = Path.Dijkstra(G)(G.Weight) 235 | 236 | end 237 | 238 | module Traverse = struct 239 | 240 | module Dfs = Traverse.Dfs(G) 241 | module Bfs = Traverse.Bfs(G) 242 | 243 | end 244 | 245 | module Coloring = Coloring.Make(G) 246 | 247 | module Topological = Topological.Make(G) 248 | 249 | module Kruskal = Kruskal.Make(G)(G.Ordered_label) 250 | 251 | module Prim = Prim.Make(G)(G.Weight) 252 | 253 | module Leaderlist = Leaderlist.Make(G) 254 | 255 | module Dominator = Dominator.Make(struct 256 | include G 257 | let create ?size:_ _ = assert false 258 | let add_edge _ _ = assert false 259 | end) 260 | --------------------------------------------------------------------------------