l4/pkg/ocaml/ocaml/contrib/bytecomp/simplif.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id: simplif.ml 8850 2008-03-19 10:26:56Z maranget $ *)
  14
  15 (* Elimination of useless Llet(Alias) bindings.
  16    Also transform let-bound references into variables. *)
  17
  18 open Asttypes
  19 open Lambda
  20
  21 (* To transform let-bound references into variables *)
  22
  23 exception Real_reference
  24
  25 let rec eliminate_ref id = function
  26     Lvar v as lam ->
  27       if Ident.same v id then raise Real_reference else lam
  28   | Lconst cst as lam -> lam
  29   | Lapply(e1, el, loc) ->
  30       Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc)
  31   | Lfunction(kind, params, body) as lam ->
  32       if IdentSet.mem id (free_variables lam)
  33       then raise Real_reference
  34       else lam
  35   | Llet(str, v, e1, e2) ->
  36       Llet(str, v, eliminate_ref id e1, eliminate_ref id e2)
  37   | Lletrec(idel, e2) ->
  38       Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel,
  39               eliminate_ref id e2)
  40   | Lprim(Pfield 0, [Lvar v]) when Ident.same v id ->
  41       Lvar id
  42   | Lprim(Psetfield(0, _), [Lvar v; e]) when Ident.same v id ->
  43       Lassign(id, eliminate_ref id e)
  44   | Lprim(Poffsetref delta, [Lvar v]) when Ident.same v id ->
  45       Lassign(id, Lprim(Poffsetint delta, [Lvar id]))
  46   | Lprim(p, el) ->
  47       Lprim(p, List.map (eliminate_ref id) el)
  48   | Lswitch(e, sw) ->
  49       Lswitch(eliminate_ref id e,
  50         {sw_numconsts = sw.sw_numconsts;
  51          sw_consts =
  52             List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_consts;
  53          sw_numblocks = sw.sw_numblocks;
  54          sw_blocks =
  55             List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks;
  56          sw_failaction = match sw.sw_failaction with
  57          | None -> None
  58          | Some l -> Some (eliminate_ref id l)})
  59   | Lstaticraise (i,args) ->
  60       Lstaticraise (i,List.map (eliminate_ref id) args)
  61   | Lstaticcatch(e1, i, e2) ->
  62       Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2)
  63   | Ltrywith(e1, v, e2) ->
  64       Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2)
  65   | Lifthenelse(e1, e2, e3) ->
  66       Lifthenelse(eliminate_ref id e1,
  67                   eliminate_ref id e2,
  68                   eliminate_ref id e3)
  69   | Lsequence(e1, e2) ->
  70       Lsequence(eliminate_ref id e1, eliminate_ref id e2)
  71   | Lwhile(e1, e2) ->
  72       Lwhile(eliminate_ref id e1, eliminate_ref id e2)
  73   | Lfor(v, e1, e2, dir, e3) ->
  74       Lfor(v, eliminate_ref id e1, eliminate_ref id e2,
  75            dir, eliminate_ref id e3)
  76   | Lassign(v, e) ->
  77       Lassign(v, eliminate_ref id e)
  78   | Lsend(k, m, o, el) ->
  79       Lsend(k, eliminate_ref id m, eliminate_ref id o,
  80             List.map (eliminate_ref id) el)
  81   | Levent(l, ev) ->
  82       Levent(eliminate_ref id l, ev)
  83   | Lifused(v, e) ->
  84       Lifused(v, eliminate_ref id e)
  85
  86 (* Simplification of exits *)
  87
  88 let simplify_exits lam =
  89
  90   (* Count occurrences of (exit n ...) statements *)
  91   let exits = Hashtbl.create 17 in
  92
  93   let count_exit i =
  94     try
  95       !(Hashtbl.find exits i)
  96     with
  97     | Not_found -> 0
  98
  99   and incr_exit i =
 100     try
 101       incr (Hashtbl.find exits i)
 102     with
 103     | Not_found -> Hashtbl.add exits i (ref 1) in
 104
 105   let rec count = function
 106   | (Lvar _| Lconst _) -> ()
 107   | Lapply(l1, ll, _) -> count l1; List.iter count ll
 108   | Lfunction(kind, params, l) -> count l
 109   | Llet(str, v, l1, l2) ->
 110       count l2; count l1
 111   | Lletrec(bindings, body) ->
 112       List.iter (fun (v, l) -> count l) bindings;
 113       count body
 114   | Lprim(p, ll) -> List.iter count ll
 115   | Lswitch(l, sw) ->
 116       count_default sw ;
 117       count l;
 118       List.iter (fun (_, l) -> count l) sw.sw_consts;
 119       List.iter (fun (_, l) -> count l) sw.sw_blocks
 120   | Lstaticraise (i,ls) -> incr_exit i ; List.iter count ls
 121   | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) ->
 122       (* i will be replaced by j in l1, so each occurence of i in l1
 123          increases j's ref count *)
 124       count l1 ;
 125       let ic = count_exit i in
 126       begin try
 127         let r = Hashtbl.find exits j in r := !r + ic
 128       with
 129       | Not_found ->
 130           Hashtbl.add exits j (ref ic)
 131       end
 132   | Lstaticcatch(l1, (i,_), l2) ->
 133       count l1;
 134       (* If l1 does not contain (exit i),
 135          l2 will be removed, so don't count its exits *)
 136       if count_exit i > 0 then
 137         count l2
 138   | Ltrywith(l1, v, l2) -> count l1; count l2
 139   | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3
 140   | Lsequence(l1, l2) -> count l1; count l2
 141   | Lwhile(l1, l2) -> count l1; count l2
 142   | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3
 143   | Lassign(v, l) ->
 144       (* Lalias-bound variables are never assigned, so don't increase
 145          v's refcount *)
 146       count l
 147   | Lsend(k, m, o, ll) -> List.iter count (m::o::ll)
 148   | Levent(l, _) -> count l
 149   | Lifused(v, l) -> count l
 150
 151   and count_default sw = match sw.sw_failaction with
 152   | None -> ()
 153   | Some al ->
 154       let nconsts = List.length sw.sw_consts
 155       and nblocks = List.length sw.sw_blocks in
 156       if
 157         nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks
 158       then begin (* default action will occur twice in native code *)
 159         count al ; count al
 160       end else begin (* default action will occur once *)
 161         assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ;
 162         count al
 163       end
 164   in
 165   count lam;
 166
 167   (*
 168      Second pass simplify  ``catch body with (i ...) handler''
 169       - if (exit i ...) does not occur in body, suppress catch
 170       - if (exit i ...) occurs exactly once in body,
 171         substitute it with handler
 172       - If handler is a single variable, replace (exit i ..) with it
 173    Note:
 174     In ``catch body with (i x1 .. xn) handler''
 175      Substituted expression is
 176       let y1 = x1 and ... yn = xn in
 177       handler[x1 <- y1 ; ... ; xn <- yn]
 178      For the sake of preserving the uniqueness  of bound variables.
 179      (No alpha conversion of ``handler'' is presently needed, since
 180      substitution of several ``(exit i ...)''
 181      occurs only when ``handler'' is a variable.)
 182   *)
 183
 184   let subst = Hashtbl.create 17 in
 185
 186   let rec simplif = function
 187   | (Lvar _|Lconst _) as l -> l
 188   | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
 189   | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
 190   | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
 191   | Lletrec(bindings, body) ->
 192       Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
 193   | Lprim(p, ll) -> Lprim(p, List.map simplif ll)
 194   | Lswitch(l, sw) ->
 195       let new_l = simplif l
 196       and new_consts =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
 197       and new_blocks =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks
 198       and new_fail = match sw.sw_failaction with
 199       | None -> None
 200       | Some l -> Some (simplif l) in
 201       Lswitch
 202         (new_l,
 203          {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
 204                   sw_failaction = new_fail})
 205   | Lstaticraise (i,[]) as l ->
 206       begin try
 207         let _,handler =  Hashtbl.find subst i in
 208         handler
 209       with
 210       | Not_found -> l
 211       end
 212   | Lstaticraise (i,ls) ->
 213       let ls = List.map simplif ls in
 214       begin try
 215         let xs,handler =  Hashtbl.find subst i in
 216         let ys = List.map Ident.rename xs in
 217         let env =
 218           List.fold_right2
 219             (fun x y t -> Ident.add x (Lvar y) t)
 220             xs ys Ident.empty in
 221         List.fold_right2
 222           (fun y l r -> Llet (Alias, y, l, r))
 223           ys ls (Lambda.subst_lambda env handler)
 224       with
 225       | Not_found -> Lstaticraise (i,ls)
 226       end
 227   | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) ->
 228       Hashtbl.add subst i ([],simplif l2) ;
 229       simplif l1
 230   | Lstaticcatch (l1,(i,xs), (Lvar _ as l2)) ->
 231       begin match count_exit i with
 232       | 0 -> simplif l1
 233       | _ ->
 234           Hashtbl.add subst i (xs,l2) ;
 235           simplif l1
 236       end
 237   | Lstaticcatch (l1,(i,xs),l2) ->
 238       begin match count_exit i with
 239       | 0 -> simplif l1
 240       | 1 ->
 241           Hashtbl.add subst i (xs,simplif l2) ;
 242           simplif l1
 243       | _ ->
 244           Lstaticcatch (simplif l1, (i,xs), simplif l2)
 245       end
 246   | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
 247   | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
 248   | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2)
 249   | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2)
 250   | Lfor(v, l1, l2, dir, l3) ->
 251       Lfor(v, simplif l1, simplif l2, dir, simplif l3)
 252   | Lassign(v, l) -> Lassign(v, simplif l)
 253   | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
 254   | Levent(l, ev) -> Levent(simplif l, ev)
 255   | Lifused(v, l) -> Lifused (v,simplif l)
 256   in
 257   simplif lam
 258
 259 (* Simplification of lets *)
 260
 261 let simplify_lets lam =
 262
 263   (* First pass: count the occurrences of all identifiers *)
 264   let occ = Hashtbl.create 83 in
 265   let count_var v =
 266     try
 267       !(Hashtbl.find occ v)
 268     with Not_found ->
 269       0
 270   and incr_var v =
 271     try
 272       incr(Hashtbl.find occ v)
 273     with Not_found ->
 274       Hashtbl.add occ v (ref 1) in
 275
 276   let rec count = function
 277   | Lvar v -> incr_var v
 278   | Lconst cst -> ()
 279   | Lapply(l1, ll, _) -> count l1; List.iter count ll
 280   | Lfunction(kind, params, l) -> count l
 281   | Llet(str, v, Lvar w, l2) when not !Clflags.debug ->
 282       (* v will be replaced by w in l2, so each occurrence of v in l2
 283          increases w's refcount *)
 284       count l2;
 285       let vc = count_var v in
 286       begin try
 287         let r = Hashtbl.find occ w in r := !r + vc
 288       with Not_found ->
 289         Hashtbl.add occ w (ref vc)
 290       end
 291   | Llet(str, v, l1, l2) ->
 292       count l2;
 293       (* If v is unused, l1 will be removed, so don't count its variables *)
 294       if str = Strict || count_var v > 0 then count l1
 295   | Lletrec(bindings, body) ->
 296       List.iter (fun (v, l) -> count l) bindings;
 297       count body
 298   | Lprim(p, ll) -> List.iter count ll
 299   | Lswitch(l, sw) ->
 300       count_default sw ;
 301       count l;
 302       List.iter (fun (_, l) -> count l) sw.sw_consts;
 303       List.iter (fun (_, l) -> count l) sw.sw_blocks
 304   | Lstaticraise (i,ls) -> List.iter count ls
 305   | Lstaticcatch(l1, (i,_), l2) ->
 306       count l1; count l2
 307   | Ltrywith(l1, v, l2) -> count l1; count l2
 308   | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3
 309   | Lsequence(l1, l2) -> count l1; count l2
 310   | Lwhile(l1, l2) -> count l1; count l2
 311   | Lfor(_, l1, l2, dir, l3) -> count l1; count l2; count l3
 312   | Lassign(v, l) ->
 313       (* Lalias-bound variables are never assigned, so don't increase
 314          v's refcount *)
 315       count l
 316   | Lsend(_, m, o, ll) -> List.iter count (m::o::ll)
 317   | Levent(l, _) -> count l
 318   | Lifused(v, l) ->
 319       if count_var v > 0 then count l
 320
 321   and count_default sw = match sw.sw_failaction with
 322   | None -> ()
 323   | Some al ->
 324       let nconsts = List.length sw.sw_consts
 325       and nblocks = List.length sw.sw_blocks in
 326       if
 327         nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks
 328       then begin (* default action will occur twice in native code *)
 329         count al ; count al
 330       end else begin (* default action will occur once *)
 331         assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ;
 332         count al
 333       end
 334   in
 335   count lam;
 336   (* Second pass: remove Lalias bindings of unused variables,
 337      and substitute the bindings of variables used exactly once. *)
 338
 339   let subst = Hashtbl.create 83 in
 340
 341   let rec simplif = function
 342     Lvar v as l ->
 343       begin try
 344         Hashtbl.find subst v
 345       with Not_found ->
 346         l
 347       end
 348   | Lconst cst as l -> l
 349   | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
 350   | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
 351   | Llet(str, v, Lvar w, l2) when not !Clflags.debug ->
 352       Hashtbl.add subst v (simplif (Lvar w));
 353       simplif l2
 354   | Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [linit]), lbody)
 355     when not !Clflags.debug ->
 356       let slinit = simplif linit in
 357       let slbody = simplif lbody in
 358       begin try
 359         Llet(Variable, v, slinit, eliminate_ref v slbody)
 360       with Real_reference ->
 361         Llet(Strict, v, Lprim(Pmakeblock(0, Mutable), [slinit]), slbody)
 362       end
 363   | Llet(Alias, v, l1, l2) ->
 364       begin match count_var v with
 365         0 -> simplif l2
 366       | 1 when not !Clflags.debug ->
 367              Hashtbl.add subst v (simplif l1); simplif l2
 368       | n -> Llet(Alias, v, simplif l1, simplif l2)
 369       end
 370   | Llet(StrictOpt, v, l1, l2) ->
 371       begin match count_var v with
 372         0 -> simplif l2
 373       | n -> Llet(Alias, v, simplif l1, simplif l2)
 374       end
 375   | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
 376   | Lletrec(bindings, body) ->
 377       Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
 378   | Lprim(p, ll) -> Lprim(p, List.map simplif ll)
 379   | Lswitch(l, sw) ->
 380       let new_l = simplif l
 381       and new_consts =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
 382       and new_blocks =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks
 383       and new_fail = match sw.sw_failaction with
 384       | None -> None
 385       | Some l -> Some (simplif l) in
 386       Lswitch
 387         (new_l,
 388          {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
 389                   sw_failaction = new_fail})
 390   | Lstaticraise (i,ls) ->
 391       Lstaticraise (i, List.map simplif ls)
 392   | Lstaticcatch(l1, (i,args), l2) ->
 393       Lstaticcatch (simplif l1, (i,args), simplif l2)
 394   | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
 395   | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
 396   | Lsequence(Lifused(v, l1), l2) ->
 397       if count_var v > 0
 398       then Lsequence(simplif l1, simplif l2)
 399       else simplif l2
 400   | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2)
 401   | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2)
 402   | Lfor(v, l1, l2, dir, l3) ->
 403       Lfor(v, simplif l1, simplif l2, dir, simplif l3)
 404   | Lassign(v, l) -> Lassign(v, simplif l)
 405   | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
 406   | Levent(l, ev) -> Levent(simplif l, ev)
 407   | Lifused(v, l) ->
 408       if count_var v > 0 then simplif l else lambda_unit
 409   in
 410   simplif lam
 411
 412 let simplify_lambda lam = simplify_lets (simplify_exits lam)