source/xi_lib/logger.ml


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
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170

module FS = struct

  let removedir =
    let rec rm path item =
      let p = (Filename.concat path item) in
      if Sys.is_directory p then
        let items = Sys.readdir p in
        Array.iter (rm p) items;
        Unix.rmdir p;
      else
        Sys.remove p
    in 
    fun item ->
      if Sys.file_exists item then
        rm "" item


  let xilog_dir = ref "xilog"

  let init xilog =
    xilog_dir := xilog;
    removedir xilog;
    Unix.mkdir xilog 0o777
end


module State = struct

  let extra_debug = ref false

  let counter = ref 0 

  let phase_name = ref ""

  let proc_name = ref ""

  let log_file_name  = ref ""

  let log_file_handle : out_channel option ref = ref None

  let get_lof_file_handle () =
    match !log_file_handle with
    | Some handle ->
      handle
    | None ->
      assert (!log_file_name <> "");
      let handle = open_out !log_file_name in
      log_file_handle := Some handle;
      handle

  let close_log_file () =
    match !log_file_handle with
      | None ->
        ()
      | Some handle ->
        close_out handle;
        log_file_name := "";
        log_file_handle := None

  let make_entry_name = function
    | () when !phase_name <> "" && !proc_name <> "" ->
      Format.sprintf "%03u.%s.%s" !counter !phase_name !proc_name
    | () when !phase_name <> "" ->
      Format.sprintf "%03u.%s" !counter !phase_name
    | _ ->
      Format.sprintf "%03u.unknown-phase" !counter

  let allocate_file_name title = 
    let r = Format.sprintf "%s/%s.%s" !FS.xilog_dir (make_entry_name ()) title in
    incr counter;
    r

  let set_new_phase name =
    phase_name := name;
    proc_name := "";
    close_log_file ();
    log_file_name := allocate_file_name "log"


  let set_proc_phase procid =
    proc_name := Ir_utils.string_of_procid procid;
    close_log_file ();
    log_file_name := allocate_file_name "log"


  let close_phase_proc () =
    proc_name := "";
    close_log_file ();
    log_file_name := allocate_file_name "log"

  let set_extra_debug v =
    extra_debug := v
end


let extra_debug f =
  if !State.extra_debug then
    f ()

let set_extra_debug = State.set_extra_debug

let new_phase name =
  State.set_new_phase name

let new_phase_proc procid =
  State.set_proc_phase procid

let close_phase_proc () =
  State.close_phase_proc ()

let make_logf mname fmt =
  let cont s =
    let h = State.get_lof_file_handle () in
    let entry = Format.sprintf "%s: %s\n" mname s in
    output_string h entry;
    flush h
  in
  Format.ksprintf cont fmt

let dump_string title buffer =
  let name = State.allocate_file_name title in
  make_logf __MODULE__ "Dumping %s" (Filename.basename name);
  let h = open_out name in
  output_string h buffer;
  output_string h "\n";
  close_out h

let dump_ir_program title ir =
  let buffer = Ir_utils.string_of_program ir in
  dump_string title buffer

let dump_ir_proc title irproc =
  let buffer = Ir_utils.string_of_procedure irproc in
  dump_string title buffer

let dump_spill_costs spill_costs =
  let f (k,v) = Format.sprintf "%s -> %u" (Ir.string_of_reg k) v in 
  let seq = Hashtbl.to_seq spill_costs in
  let seq = Seq.map f seq in
  let seq = List.of_seq seq in
  let buf = String.concat "\n" @@ List.sort compare seq in
  dump_string "spill_costs" buf

let dump_spill_costs_f spill_costs =
  let f (k,v) = Format.sprintf "%s -> %f" (Ir.string_of_reg k) v in 
  let seq = Hashtbl.to_seq spill_costs in
  let seq = Seq.map f seq in
  let seq = List.of_seq seq in
  let buf = String.concat "\n" @@ List.sort compare seq in
  dump_string "spill_costs" buf


let log_ir_proc mname irproc =
  let buffer = Ir_utils.string_of_procedure irproc in
  make_logf mname "%s" buffer

let dump_interference_graph title x =
  let buffer = Analysis_visualizer.visualize_interference_graph x in
  dump_string (title ^ ".infg.xdot") buffer

let dump_live_variables title cfg table =
  let buffer = Analysis_visualizer.visualize_live_variables cfg table in
  dump_string (title ^ ".lva.xdot") buffer

let dump_constant_folding title cfg table =
  let buffer = Analysis_visualizer.visualize_constant_folding cfg table in
  dump_string (title ^ ".cfa.xdot") buffer

let init xilog =
  FS.init xilog