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 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275
|
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
(* Luc Maranget, projet Moscova, INRIA Rocquencourt *)
(* *)
(* Copyright 2001 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
open Printf
open Mysys
exception Failed
module type Config = sig
val pess : bool
val move : bool
val small_length : int
end
module Make(C:Config) = struct
let input_protect f name =
try
let chan = open_in name in
try
let r = f chan in
begin try close_in chan with _ -> () end ;
r
with e ->
begin try close_in chan with _ -> () end ;
raise e
with
| Sys_error _msg as e -> raise e
let output_protect f name =
try
let chan = open_out name in
try
let r = f chan in
begin try close_out chan with _ -> () end ;
r
with e ->
begin try close_out chan with _ -> () end ;
raise e
with
| Sys_error _msg as e -> raise e
let lex_this vdef f name =
try
input_protect
(fun input ->
let lexbuf = Lexing.from_channel input in
Location.set name lexbuf ;
Emisc.reset () ;
let r = f lexbuf in
Location.restore () ;
r)
name
with
| Emisc.LexError s ->
if !Emisc.verbose > 0 then
output_char stderr '\n' ;
Location.print_fullpos () ;
Printf.fprintf stderr "Lexer error: %s\n" s ;
Location.restore () ;
vdef
| Sys_error _ as e -> raise e
| e ->
Location.restore () ;
raise e
let lex_this_out vdef f name_in name_out =
try
input_protect
(fun input ->
let lexbuf = Lexing.from_channel input in
Location.set name_in lexbuf ;
Emisc.reset () ;
output_protect
(fun out ->
let r = f out lexbuf in
Location.restore () ;
r)
name_out)
name_in
with
| Emisc.LexError s ->
if !Emisc.verbose > 0 then
output_char stderr '\n' ;
Location.print_fullpos () ;
Printf.fprintf stderr "Lexer error: %s\n" s ;
Location.restore () ;
vdef
| Sys_error _ as e -> raise e
| e ->
Location.restore () ;
raise e
module Parse = Htmlparse.Make(C)
let process cls in_name input output =
let rec do_rec lexbuf = match Parse.main cls lexbuf with
| [] -> ()
| ts ->
if C.pess then
Pp.trees output (Explode.trees ts)
else
Ultra.main output ts ;
do_rec lexbuf in
try
let lexbuf = Lexing.from_channel input in
Location.set in_name lexbuf ;
Emisc.reset () ;
do_rec lexbuf ;
Location.restore () ;
true
with
| Emisc.LexError s ->
if !Emisc.verbose > 0 then
output_char stderr '\n' ;
Location.print_fullpos () ;
Printf.fprintf stderr "Lexer error: %s\n" s ;
Location.restore () ;
false
| Htmlparse.Error s ->
if !Emisc.verbose > 0 then
output_char stderr '\n' ;
Location.print_fullpos () ;
Printf.fprintf stderr "Parser error: %s\n" s ;
Parse.ptop () ;
Parse.reset () ;
Location.restore () ;
false
| e ->
Location.restore () ;
raise e
let classes in_name input =
try
let lexbuf = Lexing.from_channel input in
Location.set in_name lexbuf ;
Emisc.reset () ;
let cls = Parse.classes lexbuf in
Location.restore () ;
Some cls
with
| Emisc.LexError s ->
if !Emisc.verbose > 0 then
output_char stderr '\n' ;
Location.print_fullpos () ;
Printf.fprintf stderr "Lexer error: %s\n" s ;
Location.restore () ;
None
| e ->
Location.restore () ;
raise e
let chop_extension name =
try Filename.chop_extension name
with Invalid_argument _ -> name
let do_mk_out name ext =
Filename.concat
(Filename.dirname name)
(chop_extension (Filename.basename name) ^ ext)
let mk_out in_name = do_mk_out in_name ".tmp"
and mk_esp in_name = do_mk_out in_name ".esp"
let read_size name = input_protect in_channel_length name
(* Move output file to final destination if optimiser yields some gain *)
let check_output ok in_name out_name =
let final_name =
if ok then begin
let size_in = read_size in_name
and size_out = read_size out_name in
let final_name =
if size_in > size_out then begin
let dst =
if C.move then in_name
else mk_esp in_name in
rename out_name dst ;
dst
end else begin
remove out_name ;
in_name
end in
if !Emisc.verbose > 0 then begin
eprintf "Optimized %s: %d -> %d, %.2f%%\n"
final_name
size_in size_out
((float (size_in-size_out) *. 100.0) /.
float size_in)
end ;
final_name
end else begin
remove out_name ;
in_name
end in
final_name
let phase1 in_name =
let out_name = mk_out in_name in
begin try
let input = open_in in_name in
let cls =
if C.pess then None
else try classes in_name input
with e -> close_in input ; raise e in
close_in input ;
let input = open_in in_name in
let out =
try open_out out_name
with Sys_error _ as e ->
close_in input ; raise e in
let ok =
try process cls in_name input out
with e -> close_in input ; close_out out ; raise e in
close_in input ;
close_out out ;
check_output ok in_name out_name
with
| Sys_error msg ->
Printf.fprintf stderr "File error: %s\n" msg ;
in_name
| e ->
remove out_name ;
raise e
end
let phase2 name =
try
let open Emisc in
let sts = lex_this StringCount.empty Lexstyle.get name in
let m,_ =
StringCount.fold
(fun st nocc (m,n as p) ->
let withclass = 8 + String.length st + nocc * 4
and noclass = nocc * String.length st in
if withclass < noclass then
let cl = sprintf "c%03i" n in
StringMap.add st cl m,n+1
else p)
sts (StringMap.empty,0) in
if !Emisc.verbose > 1 then begin
eprintf "New classes:\n" ;
StringMap.iter
(fun st cl -> Emisc.dump_class stderr cl st)
m ;
()
end ;
let out_name = mk_out name in
let ok =
lex_this_out false
(fun out lexbuf -> Lexstyle.set m out lexbuf)
name out_name in
check_output ok name out_name
with
| Sys_error msg ->
Printf.fprintf stderr "File error: %s\n" msg ;
name
let file name =
if !Emisc.verbose > 0 then begin
Printf.fprintf stderr "Optimizing file: %s...\n%!" name
end ;
let name = phase1 name in
if not C.pess then ignore (phase2 name)
end
|