Skip to content

Commit 617734a

Browse files
NeoKaiosNeoKaios
committed
fix: licence, isolate cfg_types, rename shatter
1 parent a3d4346 commit 617734a

12 files changed

+158
-188
lines changed

‎assets/cfg-arc-renderer.html

+13
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,16 @@
1+
<!-- ----------------------------------------------------------------------- -->
2+
<!-- -->
3+
<!-- SuperBOL OSS Studio -->
4+
<!-- -->
5+
<!-- -->
6+
<!-- Copyright (c) 2024 OCamlPro SAS -->
7+
<!-- -->
8+
<!-- All rights reserved. -->
9+
<!-- This source code is licensed under the MIT license found in the -->
10+
<!-- LICENSE.md file in the root directory of this source tree. -->
11+
<!-- -->
12+
<!-- ----------------------------------------------------------------------- -->
13+
114
<!-- Base html file used to render arc cfg variant -->
215
<!DOCTYPE html>
316
<head>

‎assets/cfg-arc.css

+14
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,17 @@
1+
/* -----------------------------------------------------------------------
2+
*
3+
* SuperBOL OSS Studio
4+
*
5+
*
6+
* Copyright (c) 2024 OCamlPro SAS
7+
*
8+
* All rights reserved.
9+
* This source code is licensed under the MIT license found in the
10+
* LICENSE.md file in the root directory of this source tree.
11+
*
12+
* -----------------------------------------------------------------------
13+
*/
14+
115
html, body {
216
height: 100%;
317
}

‎assets/cfg-arc.js

+13
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,16 @@
1+
// -----------------------------------------------------------------------
2+
//
3+
// SuperBOL OSS Studio
4+
//
5+
//
6+
// Copyright (c) 2024 OCamlPro SAS
7+
//
8+
// All rights reserved.
9+
// This source code is licensed under the MIT license found in the
10+
// LICENSE.md file in the root directory of this source tree.
11+
//
12+
// -----------------------------------------------------------------------
13+
//
114
// JS file attached to cfg-arc-renderer.html
215

316
const vscode = acquireVsCodeApi()

‎assets/cfg-dot-renderer.html

+15-2
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,16 @@
1+
<!-- ----------------------------------------------------------------------- -->
2+
<!-- -->
3+
<!-- SuperBOL OSS Studio -->
4+
<!-- -->
5+
<!-- -->
6+
<!-- Copyright (c) 2024 OCamlPro SAS -->
7+
<!-- -->
8+
<!-- All rights reserved. -->
9+
<!-- This source code is licensed under the MIT license found in the -->
10+
<!-- LICENSE.md file in the root directory of this source tree. -->
11+
<!-- -->
12+
<!-- ----------------------------------------------------------------------- -->
13+
114
<!-- Credit @beicause in https://github.com/beicause/call-graph/blob/master/src/html.ts -->
215
<!-- Base html file for rendering graphviz cfg variant -->
316
<!DOCTYPE html>
@@ -31,8 +44,8 @@ <h2 id="title">Title</h2>
3144
<label for="unreachable">Remove unreachable nodes</label></div>
3245
<div><input type="checkbox" id="fallthru" />
3346
<label for="fallthru">Collapse fallthrough transitions</label></div>
34-
<div><input type="checkbox" id="hubshatter"/>
35-
<label for="hubshatter">Split nodes with more than
47+
<div><input type="checkbox" id="in_degree_upper_limit"/>
48+
<label for="in_degree_upper_limit">Split nodes with more than
3649
<input type="number" id="hubcount" value="20" /> incoming edges</label>
3750
</div>
3851
<hr/>

‎assets/cfg-dot.css

+14
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,17 @@
1+
/* -----------------------------------------------------------------------
2+
*
3+
* SuperBOL OSS Studio
4+
*
5+
*
6+
* Copyright (c) 2024 OCamlPro SAS
7+
*
8+
* All rights reserved.
9+
* This source code is licensed under the MIT license found in the
10+
* LICENSE.md file in the root directory of this source tree.
11+
*
12+
* -----------------------------------------------------------------------
13+
*/
14+
115
html, body {
216
height: 100%;
317
}

‎assets/cfg-dot.js

+22-9
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,16 @@
1+
// -----------------------------------------------------------------------
2+
//
3+
// SuperBOL OSS Studio
4+
//
5+
//
6+
// Copyright (c) 2024 OCamlPro SAS
7+
//
8+
// All rights reserved.
9+
// This source code is licensed under the MIT license found in the
10+
// LICENSE.md file in the root directory of this source tree.
11+
//
12+
// -----------------------------------------------------------------------
13+
//
114
// JS file attached to cfg-dot-renderer.html
215

316
const legend = `digraph legend {
@@ -39,7 +52,7 @@ const defaultOptions = {
3952
split_nodes: [],
4053
hide_unreachable: false,
4154
collapse_fallthru: false,
42-
shatter_hubs: undefined,
55+
in_degree_upper_limit: undefined,
4356
}
4457
var renderOptions = defaultOptions;
4558
var rendering = d3.select('#rendering')
@@ -112,12 +125,12 @@ function setRenderOptions(renderOptions_) {
112125
renderOptions.hide_unreachable;
113126
document.getElementById("fallthru").checked =
114127
renderOptions.collapse_fallthru;
115-
document.getElementById("hubshatter").checked =
116-
renderOptions.shatter_hubs != undefined;
128+
document.getElementById("in_degree_upper_limit").checked =
129+
renderOptions.in_degree_upper_limit != undefined;
117130
document.getElementById("hubcount").value =
118-
renderOptions.shatter_hubs == undefined
131+
renderOptions.in_degree_upper_limit == undefined
119132
? "20"
120-
: String(renderOptions.shatter_hubs);
133+
: String(renderOptions.in_degree_upper_limit);
121134
const nodeElements = document.querySelectorAll(".nodes-list > p");
122135
for (let p of nodeElements) {
123136
p.remove();
@@ -137,17 +150,17 @@ function setRenderOptions(renderOptions_) {
137150
function rerender() {
138151
var collapse_fallthru = document.getElementById('fallthru').checked;
139152
var hide_unreachable = document.getElementById('unreachable').checked;
140-
if(document.getElementById('hubshatter').checked) {
141-
var shatter_hubs = Number(document.getElementById('hubcount').value)
153+
if(document.getElementById('in_degree_upper_limit').checked) {
154+
var in_degree_upper_limit = Number(document.getElementById('hubcount').value)
142155
}
143156
else {
144-
var shatter_hubs = undefined;
157+
var in_degree_upper_limit = undefined;
145158
}
146159
renderOptions = {
147160
...renderOptions,
148161
hide_unreachable,
149162
collapse_fallthru,
150-
shatter_hubs,
163+
in_degree_upper_limit,
151164
};
152165
vscode.postMessage({ type: 'graph_update', renderOptions })
153166
}

‎src/lsp/cobol_cfg/cfg_builder.ml

+7-41
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ open Cobol_common.Srcloc.INFIX
1313
open Cobol_common.Srcloc.TYPES
1414
open Cobol_unit.Types
1515
open Cfg_jumps
16+
open Cfg_types
1617
module NEL = Cobol_common.Basics.NEL
1718

1819
(* TYPES AND HELPERS *)
@@ -55,48 +56,11 @@ let entry_stmt_to_string_loc = function
5556

5657
(* CFG MODULE *)
5758

58-
type node_type =
59-
| External of string
60-
| Entry of [`Point | `Paragraph | `Section of string | `Statement of string]
61-
| Normal of string * string (* fullname * display_name *)
62-
| Collapsed of string NEL.t
63-
| Split of string
64-
65-
type node = {
66-
id: int;
67-
section_name: string;
68-
loc: srcloc option;
69-
typ: node_type;
70-
jumps: Jumps.t;
71-
will_fallthru: bool;
72-
terminal: bool; (* unused atm *)
73-
}
74-
7559
let is_entry n =
7660
match n.typ with
7761
| External _ | Normal _ | Collapsed _ | Split _ -> false
7862
| Entry _ -> true
7963

80-
type edge =
81-
| FallThrough
82-
| Perform
83-
| Go
84-
85-
module Node = struct
86-
type t = node
87-
let compare node other = Int.compare node.id other.id
88-
let hash node = Hashtbl.hash node.id
89-
let equal node other = Int.equal node.id other.id
90-
end
91-
92-
module Edge = struct
93-
type t = edge
94-
let compare = Stdlib.compare
95-
let default = FallThrough
96-
end
97-
98-
module Cfg = Graph.Persistent.Digraph.ConcreteLabeled(Node)(Edge)
99-
10064
(* DEFAULT CFG BUILDER FUNCTION *)
10165

10266
let node_idx = ref 0
@@ -346,8 +310,8 @@ let do_hide_unreachable g =
346310
let clone_node node =
347311
{ node with id = next_node_idx (); }
348312

349-
let do_shatter_nodes ~ids ~limit g =
350-
let shatter_typ { typ; _ } =
313+
let do_split_nodes ~ids ~limit g =
314+
let split_typ { typ; _ } =
351315
match typ with
352316
| External name -> Some (External name, true)
353317
| Normal (_, name) -> Some (Split name, false)
@@ -359,7 +323,7 @@ let do_shatter_nodes ~ids ~limit g =
359323
| None -> false
360324
in
361325
Cfg.fold_vertex begin fun n cfg ->
362-
match shatter_typ n with
326+
match split_typ n with
363327
| Some (typ, remove_original)
364328
when is_above_limit n || List.mem n.id ids ->
365329
let cfg = Cfg.fold_pred_e begin fun edge cfg ->
@@ -447,7 +411,9 @@ let handle_cfg_options ~(options: Cfg_options.t) cfg =
447411
|> (match options.hidden_nodes with
448412
| [] -> Fun.id
449413
| l -> remove_nodes l)
450-
|> do_shatter_nodes ~ids:options.split_nodes ~limit:options.shatter_hubs
414+
|> do_split_nodes
415+
~ids:options.split_nodes
416+
~limit:options.in_degree_upper_limit
451417
|> (if options.collapse_fallthru then do_collapse_fallthru else Fun.id)
452418

453419
(* GRAPH OUTPUT FORMAT *)

‎src/lsp/cobol_cfg/cfg_builder.mli

+1-129
Original file line numberDiff line numberDiff line change
@@ -8,135 +8,7 @@
88
(* *)
99
(******************************************************************************)
1010

11-
open Cfg_jumps
12-
13-
type node_type =
14-
| External of string
15-
| Entry of [`Point | `Paragraph | `Section of string | `Statement of string]
16-
| Normal of string * string (* fullname * display_name *)
17-
| Collapsed of string Cobol_common.Basics.NEL.t
18-
| Split of string
19-
20-
type node = {
21-
id: int;
22-
section_name: string;
23-
loc: Cobol_common.srcloc option;
24-
typ: node_type;
25-
jumps: Jumps.t;
26-
will_fallthru: bool;
27-
terminal: bool; (* unused atm *)
28-
}
29-
30-
module Node: sig
31-
type t = node
32-
33-
val compare : node -> node -> int
34-
val hash : node -> int
35-
val equal : node -> node -> bool
36-
end
37-
38-
type edge =
39-
| FallThrough
40-
| Perform
41-
| Go
42-
43-
module Edge: sig
44-
type t = edge
45-
46-
val compare : 'a -> 'a -> int
47-
val default : edge
48-
end
49-
50-
module Cfg :
51-
sig
52-
type t
53-
54-
module V : sig
55-
type t = node
56-
57-
val compare : t -> t -> int
58-
val hash : t -> int
59-
val equal : t -> t -> bool
60-
61-
type label = t
62-
63-
val create : label -> t
64-
val label : t -> label
65-
end
66-
67-
type vertex = node
68-
69-
module E : sig
70-
type t = vertex * edge * vertex
71-
72-
val compare : t -> t -> int
73-
74-
type vertex = node
75-
76-
val src : t -> vertex
77-
val dst : t -> vertex
78-
79-
type label = edge
80-
81-
val create : vertex -> label -> vertex -> t
82-
val label : t -> label
83-
end
84-
85-
type edge = E.t
86-
87-
val is_directed : bool
88-
val is_empty : t -> bool
89-
val nb_vertex : t -> int
90-
val nb_edges : t -> int
91-
val out_degree : t -> vertex -> int
92-
val in_degree : t -> vertex -> int
93-
val mem_vertex : t -> vertex -> bool
94-
val mem_edge : t -> vertex -> vertex -> bool
95-
val mem_edge_e : t -> edge -> bool
96-
val find_edge : t -> vertex -> vertex -> edge
97-
val find_all_edges : t -> vertex -> vertex -> edge list
98-
val succ : t -> vertex -> vertex list
99-
val pred : t -> vertex -> vertex list
100-
val succ_e : t -> vertex -> edge list
101-
val pred_e : t -> vertex -> edge list
102-
val iter_vertex : (vertex -> unit) -> t -> unit
103-
val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a
104-
val iter_edges : (vertex -> vertex -> unit) -> t -> unit
105-
106-
val fold_edges :
107-
(vertex -> vertex -> 'a -> 'a) -> t -> 'a -> 'a
108-
109-
val iter_edges_e : (edge -> unit) -> t -> unit
110-
val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a
111-
val map_vertex : (vertex -> vertex) -> t -> t
112-
val iter_succ : (vertex -> unit) -> t -> vertex -> unit
113-
val iter_pred : (vertex -> unit) -> t -> vertex -> unit
114-
115-
val fold_succ :
116-
(vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a
117-
118-
val fold_pred :
119-
(vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a
120-
121-
val iter_succ_e : (edge -> unit) -> t -> vertex -> unit
122-
123-
val fold_succ_e :
124-
(edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a
125-
126-
val iter_pred_e : (edge -> unit) -> t -> vertex -> unit
127-
128-
val fold_pred_e :
129-
(edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a
130-
131-
val empty : t
132-
val add_vertex : t -> vertex -> t
133-
val remove_vertex : t -> vertex -> t
134-
val add_edge : t -> vertex -> vertex -> t
135-
val add_edge_e : t -> edge -> t
136-
val remove_edge : t -> vertex -> vertex -> t
137-
val remove_edge_e : t -> edge -> t
138-
end
139-
11+
open Cfg_types
14012

14113
val make
14214
: options:Cfg_options.t

0 commit comments

Comments
 (0)