Skip to content

Commit 8ed2d4c

Browse files
hhugohhugo
committed
refactor
1 parent 8b48214 commit 8ed2d4c

File tree

5 files changed

+91
-84
lines changed

5 files changed

+91
-84
lines changed

‎compiler/lib/driver.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -719,10 +719,10 @@ let full ~standalone ~wrap_with_fun ~profile ~link ~source_map formatter d p =
719719
in
720720
if times () then Format.eprintf "Start Optimizing...@.";
721721
let t = Timer.make () in
722-
let (((prog, live_vars), (cps_calls, shapes))) = opt p in
722+
let (prog, live_vars), (cps_calls, shapes) = opt p in
723723
StringMap.iter
724724
(fun name shape ->
725-
Shape.set_shape ~name shape;
725+
Shape.Store.set ~name shape;
726726
Pretty_print.string
727727
formatter
728728
(Printf.sprintf "//# shape: %s:%s\n" name (Shape.to_string shape)))

‎compiler/lib/flow.ml

Lines changed: 34 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -149,7 +149,7 @@ let propagate1 deps defs st x =
149149
| Constant _ | Apply _ | Prim _ | Special _ | Closure _ | Block _ ->
150150
Var.Set.singleton x
151151
| Field (y, n) ->
152-
if Option.is_some (Shape.get x)
152+
if Option.is_some (Shape.State.get x)
153153
then Var.Set.singleton x
154154
else
155155
var_set_lift
@@ -282,7 +282,7 @@ let propagate2 ?(skip_param = false) defs known_origins possibly_mutable st x =
282282
match e with
283283
| Constant _ | Closure _ | Apply _ | Prim _ | Block _ | Special _ -> false
284284
| Field (y, n) ->
285-
Option.is_none (Shape.get x)
285+
Option.is_none (Shape.State.get x)
286286
&& (Var.Tbl.get st y
287287
|| Var.Set.exists
288288
(fun z ->
@@ -399,43 +399,38 @@ let direct_approx (info : Info.t) x =
399399

400400
let rec the_shape_of info x =
401401
let rec loop info x acc : Shape.t =
402-
match Shape.get x with
403-
| Some shape -> shape
404-
| None ->
405-
get_approx
406-
info
407-
(fun x ->
408-
match Shape.get x with
409-
| Some shape -> shape
410-
| None -> (
411-
match info.info_defs.(Var.idx x) with
412-
| Expr (Block (_, a, _, Immutable)) ->
413-
Shape.Block (List.map ~f:(the_shape_of info) (Array.to_list a))
414-
| Expr (Closure (l, _)) ->
415-
Shape.Function
416-
{ arity = List.length l; pure = false; res = Top "unk" }
417-
| Expr (Special (Alias_prim name)) -> (
418-
try
419-
let arity = Primitive.arity name in
420-
let pure = Primitive.is_pure name in
421-
Shape.Function { arity; pure; res = Top "unk" }
422-
with _ -> Top "other")
423-
| Expr (Apply { f; args; _ }) -> (
424-
if List.mem f ~set:acc
425-
then Top "loop"
426-
else
427-
match loop info f (f :: acc) with
428-
| Shape.Function { arity = n; _ } ->
429-
let diff = n - List.length args in
430-
if diff > 0
431-
then
432-
Shape.Function { arity = diff; pure = false; res = Top "unk" }
433-
else Shape.Top "apply"
434-
| Shape.Block _ | Shape.Top _ -> Shape.Top "apply2")
435-
| _ -> Shape.Top "other"))
436-
(Top "init")
437-
(fun _u _v -> Shape.Top "merge")
438-
x
402+
get_approx
403+
info
404+
(fun x ->
405+
match Shape.State.get x with
406+
| Some shape -> shape
407+
| None -> (
408+
match info.info_defs.(Var.idx x) with
409+
| Expr (Block (_, a, _, Immutable)) ->
410+
Shape.Block (List.map ~f:(the_shape_of info) (Array.to_list a))
411+
| Expr (Closure (l, _)) ->
412+
Shape.Function { arity = List.length l; pure = false; res = Top "unk" }
413+
| Expr (Special (Alias_prim name)) -> (
414+
try
415+
let arity = Primitive.arity name in
416+
let pure = Primitive.is_pure name in
417+
Shape.Function { arity; pure; res = Top "unk" }
418+
with _ -> Top "other")
419+
| Expr (Apply { f; args; _ }) -> (
420+
if true || List.mem f ~set:acc
421+
then Top "loop"
422+
else
423+
match loop info f (f :: acc) with
424+
| Shape.Function { arity = n; _ } ->
425+
let diff = n - List.length args in
426+
if diff > 0
427+
then Shape.Function { arity = diff; pure = false; res = Top "unk" }
428+
else Shape.Top "apply"
429+
| Shape.Block _ | Shape.Top _ -> Shape.Top "apply2")
430+
| _ -> Shape.Top "other"))
431+
(Top "init")
432+
(fun _u _v -> Shape.Top "merge")
433+
x
439434
in
440435
loop info x []
441436

‎compiler/lib/parse_bytecode.ml

Lines changed: 10 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -818,9 +818,9 @@ let get_global state instrs i loc =
818818
(match g.named_value.(i) with
819819
| None -> ()
820820
| Some name -> (
821-
match Shape.get_shape ~name with
821+
match Shape.Store.get ~name with
822822
| None -> ()
823-
| Some shape -> Shape.assign x shape));
823+
| Some shape -> Shape.State.assign x shape));
824824

825825
x, state, instrs)
826826

@@ -1378,7 +1378,7 @@ and compile infos pc state instrs =
13781378
let j = getu code (pc + 2) in
13791379
let y, state = State.fresh_var state loc in
13801380
if debug_parser () then Format.printf "%a = %a[%d]@." Var.print y Var.print x j;
1381-
Shape.propagate x j y;
1381+
Shape.State.propagate x j y;
13821382
compile infos (pc + 3) state ((Let (y, Field (x, j)), loc) :: instrs)
13831383
| PUSHGETGLOBALFIELD ->
13841384
let state = State.push state loc in
@@ -1388,7 +1388,7 @@ and compile infos pc state instrs =
13881388
let j = getu code (pc + 2) in
13891389
let y, state = State.fresh_var state loc in
13901390
if debug_parser () then Format.printf "%a = %a[%d]@." Var.print y Var.print x j;
1391-
Shape.propagate x j y;
1391+
Shape.State.propagate x j y;
13921392
compile infos (pc + 3) state ((Let (y, Field (x, j)), loc) :: instrs)
13931393
| SETGLOBAL ->
13941394
let i = getu code (pc + 1) in
@@ -1555,32 +1555,32 @@ and compile infos pc state instrs =
15551555
let x, state = State.fresh_var state loc in
15561556

15571557
if debug_parser () then Format.printf "%a = %a[0]@." Var.print x Var.print y;
1558-
Shape.propagate y 0 x;
1558+
Shape.State.propagate y 0 x;
15591559
compile infos (pc + 1) state ((Let (x, Field (y, 0)), loc) :: instrs)
15601560
| GETFIELD1 ->
15611561
let y, _ = State.accu state in
15621562
let x, state = State.fresh_var state loc in
15631563
if debug_parser () then Format.printf "%a = %a[1]@." Var.print x Var.print y;
1564-
Shape.propagate y 1 x;
1564+
Shape.State.propagate y 1 x;
15651565
compile infos (pc + 1) state ((Let (x, Field (y, 1)), loc) :: instrs)
15661566
| GETFIELD2 ->
15671567
let y, _ = State.accu state in
15681568
let x, state = State.fresh_var state loc in
15691569
if debug_parser () then Format.printf "%a = %a[2]@." Var.print x Var.print y;
1570-
Shape.propagate y 2 x;
1570+
Shape.State.propagate y 2 x;
15711571
compile infos (pc + 1) state ((Let (x, Field (y, 2)), loc) :: instrs)
15721572
| GETFIELD3 ->
15731573
let y, _ = State.accu state in
15741574
let x, state = State.fresh_var state loc in
15751575
if debug_parser () then Format.printf "%a = %a[3]@." Var.print x Var.print y;
1576-
Shape.propagate y 3 x;
1576+
Shape.State.propagate y 3 x;
15771577
compile infos (pc + 1) state ((Let (x, Field (y, 3)), loc) :: instrs)
15781578
| GETFIELD ->
15791579
let y, _ = State.accu state in
15801580
let n = getu code (pc + 1) in
15811581
let x, state = State.fresh_var state loc in
15821582
if debug_parser () then Format.printf "%a = %a[%d]@." Var.print x Var.print y n;
1583-
Shape.propagate y n x;
1583+
Shape.State.propagate y n x;
15841584
compile infos (pc + 2) state ((Let (x, Field (y, n)), loc) :: instrs)
15851585
| GETFLOATFIELD ->
15861586
let y, _ = State.accu state in
@@ -2538,7 +2538,7 @@ let parse_bytecode code globals debug_data =
25382538
let immutable = ref Code.Var.Set.empty in
25392539
let state = State.initial globals immutable in
25402540
Code.Var.reset ();
2541-
Shape.reset ();
2541+
Shape.State.reset ();
25422542
let blocks = Blocks.analyse debug_data code in
25432543
let blocks =
25442544
(* Disabled. [pc] might not be an appropriate place to split blocks *)

‎compiler/lib/shape.ml

Lines changed: 33 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -34,40 +34,46 @@ let rec to_string (shape : t) =
3434
| Block l -> "[" ^ String.concat ~sep:"," (List.map ~f:to_string l) ^ "]"
3535
| Function { arity; _ } -> Printf.sprintf "F(%d)" arity
3636

37-
type key =
38-
| Name of string
39-
| Var of Code.Var.t
37+
module Store = struct
38+
module T = Hashtbl.Make (struct
39+
type t = string
4040

41-
module Hashtbl = Hashtbl.Make (struct
42-
type t = key
41+
let equal (a : t) (b : t) = String.equal a b
4342

44-
let equal a b = Poly.(a = b)
43+
let hash = Hashtbl.hash
44+
end)
4545

46-
let hash = function
47-
| Name s -> Hashtbl.hash s
48-
| Var x -> Code.Var.idx x
49-
end)
46+
let t = T.create 17
5047

51-
let state : t Hashtbl.t = Hashtbl.create 17
48+
let set ~name shape = T.replace t name shape
5249

53-
let set_shape ~name shape = Hashtbl.add state (Name name) shape
50+
let get ~name = T.find_opt t name
5451

55-
let get_shape ~name = Hashtbl.find_opt state (Name name)
52+
let load ~name:_ _dirs = None
53+
end
5654

57-
let assign x shape = Hashtbl.add state (Var x) shape
55+
module State = struct
56+
type key = Code.Var.t
5857

59-
let propagate x offset target =
60-
match Hashtbl.find_opt state (Var x) with
61-
| None -> ()
62-
| Some (Top _ | Function _) -> ()
63-
| Some (Block l) -> Hashtbl.replace state (Var target) (List.nth l offset)
58+
module T = Hashtbl.Make (struct
59+
type t = key
6460

65-
let get x = Hashtbl.find_opt state (Var x)
61+
let equal a b = Poly.(a = b)
6662

67-
let reset () =
68-
Hashtbl.to_seq_keys state
69-
|> Seq.filter (function
70-
| Name _ -> false
71-
| Var _ -> true)
72-
|> List.of_seq
73-
|> List.iter ~f:(Hashtbl.remove state)
63+
let hash = Code.Var.idx
64+
end)
65+
66+
let t = T.create 17
67+
68+
let assign x shape = T.add t x shape
69+
70+
let propagate x offset target =
71+
match T.find_opt t x with
72+
| None -> ()
73+
| Some (Top _ | Function _) -> ()
74+
| Some (Block l) -> T.replace t target (List.nth l offset)
75+
76+
let get x = T.find_opt t x
77+
78+
let reset () = T.clear t
79+
end

‎compiler/lib/shape.mli

Lines changed: 12 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -28,14 +28,20 @@ type t =
2828

2929
val to_string : t -> string
3030

31-
val set_shape : name:string -> t -> unit
31+
module Store : sig
32+
val set : name:string -> t -> unit
3233

33-
val get_shape : name:string -> t option
34+
val get : name:string -> t option
3435

35-
val propagate : Code.Var.t -> int -> Code.Var.t -> unit
36+
val load : name:string -> string list -> t option
37+
end
3638

37-
val assign : Code.Var.t -> t -> unit
39+
module State : sig
40+
val propagate : Code.Var.t -> int -> Code.Var.t -> unit
3841

39-
val get : Code.Var.t -> t option
42+
val assign : Code.Var.t -> t -> unit
4043

41-
val reset : unit -> unit
44+
val get : Code.Var.t -> t option
45+
46+
val reset : unit -> unit
47+
end

0 commit comments

Comments
 (0)